Copying selective range of column data from mutiple sheets to one sheet

[vignesh_thegame]

Hi All,

I have a workbook with 4 sheets. Each sheet has data in 10 columns. all sheets column headers are same.

I want to consolidate selective column (A: C, F:H) data from all four sheets into a new sheet under the same column header.

I have a code, but it is copying the entire columns from different sheets and consolidating in new sheet with out header.

Can any one help me to get this done?

Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"

'Fill in the start row
StartRow = 2

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets

'Loop through all worksheets except the RDBMerge worksheet and the
'Information worksheet, you can ad more sheets to the array if you want.
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Information"), 0)) Then

'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = LastRow(sh)

'If sh is not empty and if the last row >= StartRow copy the CopyRng
If shLast > 0 And shLast >= StartRow Then

'Set the range that you want to copy
'Need to check here-- Vignesh
'Set CopyRng = sh.Range("A3:G3, AH3:AJ3, AL3")
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look below example 1 on this page
CopyRng.Copy
With DestSh.Cells(1 + Last, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

End If

End If
Next

ExitTheSub:

Application.GoTo DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Peter_SSs]

If I have understood correctly, here is one way.

Sub CopyData()
  Dim sh As Worksheet, DestSh As Worksheet
  Dim Last As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error Resume Next
  ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  Sheets.Add(After:=Sheets(Sheets.Count)).Name = "RDBMergeSheet"
  Set DestSh = Sheets(Sheets.Count)
  For Each sh In Worksheets
    Select Case sh.Name
      Case "Information", "RDBMergeSheet"
      Case Else
        If IsEmpty(DestSh.Range("A1").Value) Then sh.Range("A1:H1").Copy Destination:=DestSh.Range("A1")
        Last = DestSh.UsedRange.Rows.Count
        With sh.UsedRange
          .Offset(1).Resize(.Rows.Count - 1, 8).Copy Destination:=DestSh.Range("A" & Last + 1)
        End With
    End Select
  Next sh
  DestSh.Columns("D:E").Delete
  DestSh.UsedRange.Columns.AutoFit
  Application.ScreenUpdating = True
End Sub

 

[vignesh_thegame]

Hi Peter,

Your code works perfectly till consolidating upto three sheets, after 4th sheet we could see a blank blank rows inserted before pasting the sheet 4 data...

Header 1	Header 2	Header 3	Header 6	Header 7
Cell A2 of Sheet1	Cell B2 of Sheet1	Cell C2 of Sheet1	Cell F2 of Sheet1	Cell G2 of Sheet1
Cell A3 of Sheet1	Cell B3 of Sheet1	Cell C3 of Sheet1	Cell F3 of Sheet1	Cell G3 of Sheet1
Cell A4 of Sheet1	Cell B4 of Sheet1	Cell C4 of Sheet1	Cell F4 of Sheet1	Cell G4 of Sheet1
Cell A2 of Sheet2	Cell B2 of Sheet2	Cell C2 of Sheet2	Cell F2 of Sheet2	Cell G2 of Sheet2
Cell A3 of Sheet2	Cell B3 of Sheet2	Cell C3 of Sheet2	Cell F3 of Sheet2	Cell G3 of Sheet2
Cell A4 of Sheet2	Cell B4 of Sheet2	Cell C4 of Sheet2	Cell F4 of Sheet2	Cell G4 of Sheet2
Cell A2 of Sheet3	Cell B2 of Sheet3	Cell C2 of Sheet3	Cell F2 of Sheet3	Cell G2 of Sheet3
Cell A3 of Sheet3	Cell B3 of Sheet3	Cell C3 of Sheet3	Cell F3 of Sheet3	Cell G3 of Sheet3
Cell A4 of Sheet3	Cell B4 of Sheet3	Cell C4 of Sheet3	Cell F4 of Sheet3	Cell G4 of Sheet3
Cell A2 of Sheet4	Cell B2 of Sheet4	Cell C2 of Sheet4	Cell F2 of Sheet4	Cell G2 of Sheet4
Cell A3 of Sheet4	Cell B3 of Sheet4	Cell C3 of Sheet4	Cell F3 of Sheet4	Cell G3 of Sheet4
Cell A4 of Sheet4	Cell B4 of Sheet4	Cell C4 of Sheet4	Cell F4 of Sheet4	Cell G4 of Sheet4

<colgroup><col><col span="2"><col><col></colgroup><tbody>
</tbody>

 

[Peter_SSs]

I would say that Sheet3 probably has some cells at the bottom that appear empty but contain formulas returning a null string ("") or perhaps formatting that causes them to be included in the sheet's UsedRange.
Try this vrersion to see if it fixes the problem.

Sub CopyData_v2()
  Dim sh As Worksheet, DestSh As Worksheet
  Dim Last As Long, shLast As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error Resume Next
  ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  Sheets.Add(After:=Sheets(Sheets.Count)).Name = "RDBMergeSheet"
  Set DestSh = Sheets(Sheets.Count)
  For Each sh In Worksheets
    Select Case sh.Name
      Case "Information", "RDBMergeSheet"
      Case Else
        If IsEmpty(DestSh.Range("A1").Value) Then sh.Range("A1:H1").Copy Destination:=DestSh.Range("A1")
        Last = DestSh.UsedRange.Rows.Count
        With sh
          shLast = .Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, SearchFormat:=False).Row
          .UsedRange.Offset(1).Resize(shLast - 1, 8).Copy Destination:=DestSh.Range("A" & Last + 1)
        End With
    End Select
  Next sh
  DestSh.Columns("D:E").Delete
  DestSh.UsedRange.Columns.AutoFit
  Application.ScreenUpdating = True
End Sub

 

[vignesh_thegame]

Great!!!!

Thanks and its works perfectly.. i am impressed by your work

Just for my learning purpose, Please clarify the below query,
In case, if the header is occupied on 2 columns (i.e column A1 and A2 is header) and i want to copy the the data from A3 range with A1 and A2 as header, what needs to be change in my coding...

A	B
Header	Header
Sub Header	Sub Header
Data 1	Data 1
Data 2	Data 2

<colgroup><col><col></colgroup><tbody>
</tbody>

 

[Peter_SSs]

In case, if the header is occupied on 2 columns ..

I think you mean rows?

Here is one way that allows any number of header rows, so long as each sheet is the same.

1. Add this just below the 'Dim' statements to record how many header rows you have in each sheet.

Const HdrRws As Long = 2

Then change these two lines

If IsEmpty(DestSh.Range("A1").Value) Then sh.Range("A1:H" & HdrRws).Copy Destination:=DestSh.Range("A1")

.UsedRange.Offset(HdrRws).Resize(shLast - HdrRws, 8).Copy Destination:=DestSh.Range("A" & Last + 1)

 

[vignesh_thegame]

Thank you so much. its working fine....

i would like to learn vba, is there any best website or book to understand the vba structure?

 

[Peter_SSs]

Thank you so much. its working fine....

Good to hear.

i would like to learn vba, is there any best website or book to understand the vba structure?

Most of what I know I learned from studying threads in this forum.