Combine Worksheets with blanks into single sheet - VBA

Question

I know this question has been asked several times, but no solution seemed to work for me. I have a large Workbook with data on 50 companies, spread across 50 worksheets.

My goal is to combine everything into a large "Combined" sheet, including all the data. However, the data on the worksheets sometimes has blanks. Also my code does not have a common header. Instead the first row is always the company name which should also be transferred to the combined sheet.

See my screenshot below:

I tried the below code but it only combined the headers.

Sub Combine()
 Dim J As Integer
  On Error Resume Next
  Sheets(1).Select
  Worksheets.Add
  Sheets(1).Name = "Combined"
  Sheets(2).Activate
  Range("A1").EntireRow.Select
  Selection.Copy Destination:=Sheets(1).Range("A1")
 For J = 2 To Sheets.Count
  Sheets(J).Activate
  Range("A1").Select
  Selection.CurrentRegion.Select
  Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
  Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
 Next
End Sub

Running the code gives me only the header line, but not the rest of the data.

See result:

Any suggestions would be highly appreciated, thanks!

See [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). And get rid of `On Error Resume Next`. — BigBen, Jul 09 '19 at 15:45
You also need to look up `currentregion` which is a contiguous block of data. Your row 2 is empty. — SJR, Jul 09 '19 at 15:54

AAA · Accepted Answer · 2019-07-09T22:05:59.063

0

Sub Combine()
Dim ws as Worksheet, Combined as Worksheet
Dim LastRow as Long, iRow as Long
Set Combined = ThisWorkbook.Worksheets.Add
Combined.Name = "Combined"
iRow = 1

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Combined" Then
        With ws
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                LastRow = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Row
                .Range("A1:J" & LastRow).Copy _
                    Destination:= Combined.Range("A" & iRow)
                iRow = iRow + LastRow
            End If
        End With
    End If
Next ws

End Sub

edited Jul 09 '19 at 22:05

answered Jul 09 '19 at 18:52

AAA

3,520
1
15
31

Many thanks @AAA! The code works but any idea why it most of the times (not always) forgets to copy column "J" with the datastamp? – simvor Jul 09 '19 at 19:09
I have tried it also and apart from that it works fine, but for most sheets it doesn't copy the date which is in column J. Yes, column J is the last one in all sheets. – simvor Jul 09 '19 at 21:45
@simvor, try the new code. And please mark as answer if it works. Also I am interested in why the previous code did not work. Can you manually copy Column J to a blank worksheet and see what happens? – AAA Jul 09 '19 at 22:07
thank you! Code works now including the datestamp in column J. For some reason when I copy J manually into a new sheet it doesn't copy any data. Even though there is clearly data in that column (see screenshot) – simvor Jul 10 '19 at 09:24
Can you check the formula for any entry in column J? – AAA Jul 10 '19 at 09:26

Combine Worksheets with blanks into single sheet - VBA

1 Answers1