Consolidate Sheets by Appending Rows

[Philip1957]

Greetings,

I have a macro and 2 functions that work together to consolidate multiple worksheets from the same workbook onto one new sheet by appending the data to the next empty column that works just fine.

Sub ConShtsClmn()
On Error GoTo IfError

Dim Sht As Worksheet, DstSht As Worksheet
Dim LstRow As Long, LstCol As Long, DstCol As Long
Dim i As Integer, EnRange As String
Dim SrcRng As Range

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

'Delete the Append_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Append_Data").Delete
Application.DisplayAlerts = True

'Add a new WorkSheet and name as 'Append_Data'
With ActiveWorkbook
    Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    DstSht.Name = "Append_Data"
End With

'Loop through each WorkSheet in the workbook and copy the data to the 'Append_Data' WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name <> DstSht.Name Then
       'Find the last row on the 'Append_Data' sheet
       DstCol = fn_LastColumn(DstSht)
           
       If DstCol = 1 Then DstCol = 0
               
       'Find Input data range
       LstRow = fn_LastRow(Sht)
       LstCol = fn_LastColumn(Sht)
       EnRange = Sht.Cells(LstRow, LstCol).Address
       Set SrcRng = Sht.Range("A1:" & EnRange)
       
       'Check whether there are enough columns in the 'Append_Data' Worksheet
        If DstCol + SrcRng.Columns.Count > DstSht.Columns.Count Then
            MsgBox "There are not enough columns to place the data in the Append_Data worksheet."
            GoTo IfError
        End If
                
      'Copy data to the 'Append_Data' WorkSheet
        SrcRng.Copy Destination:=DstSht.Cells(1, DstCol + 1)
    End If
Next

IfError:

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

Function fn_LastColumn(ByVal Sht As Worksheet)

    Dim lastCol As Long
    lastCol = Sht.Cells.SpecialCells(xlLastCell).Column
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
        lCol = lCol - 1
    Loop
    fn_LastColumn = lCol

End Function

Function fn_LastRow(ByVal Sht As Worksheet)

    Dim lastRow As Long
    lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
        lRow = lRow - 1
    Loop
    fn_LastRow = lRow

End Function

Maybe not the most elegant coding, but it works.

I am trying to modify the macro to do the same thing, but by appending the data to the next empty row.

Sub ConShtsRow()
On Error GoTo IfError

Dim Sht As Worksheet, DstSht As Worksheet
Dim LstRow As Long, LstCol As Long, DstRow As Long
Dim i As Integer, EnRange As String
Dim SrcRng As Range

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

'Delete the Append_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Append_Data").Delete
Application.DisplayAlerts = True

'Add a new WorkSheet and name as 'Append_Data'
With ActiveWorkbook
    Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    DstSht.Name = "Append_Data"
End With

'Loop through each WorkSheet in the workbook and copy the data to the 'Append_Data' WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name <> DstSht.Name Then
       'Find the last row on the 'Append_Data' sheet
       DstRow = fn_LastRow(DstSht)
           
       If DstRow = 1 Then DstRow = 0
               
       'Find Input data range
       LstRow = fn_LastRow(Sht)
       LstCol = fn_LastColumn(Sht)
       EnRange = Sht.Cells(LstRow, LstCol).Address
       Set SrcRng = Sht.Range("A1:" & EnRange)
       
       'Check whether there are enough rows in the 'Append_Data' Worksheet
        If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
            MsgBox "There are not enough rows to place the data in the Append_Data worksheet."
            GoTo IfError
        End If
                
      'Copy data to the 'Append_Data' WorkSheet
        SrcRng.Copy Destination:=DstSht.Cells(1, DstRow + 1) 'This is where it pastes to next empty column.
    End If
Next

IfError:

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

This compiles and generates no errors (even with error handling commented blocked). The macro runs and loops the correct number of times, but it only adds the first sheet's data to the new sheet. It doesn't append the rest of the sheets, it just goes through the motions.

Any help at all with this would be appreciated.

I haven't gotten that far yet but I'm also unsure as to how to eliminate the duplicate header rows this will create. I can either try searching for the header rows and delete them, or select the data to copy after the first sheet from row 2 down. Any help here would also be appreciated (and would avoid a second new thread).


Thanks in advance for any and all help on this problem. I'm sure I've simply forgotten or missed something stupid, and so I thank you for your patience as well.

Thanks,
~ Phil

 

[vcoolio]

Hello Phil,

As far as I can tell, you are basically consolidating the data from a number of sheets to a main sheet ("Append_Data").

Rather than delete/create the "Append_Data" sheet each time the code is executed, could you not just have the one "Append_Data" sheet (with headings) and just clear it of all existing data prior to the next transfer of data?

If so, the following shorter code will do what you need:-

Sub Append()

Dim ws As Worksheet, ws1 As Worksheet
Set ws1 = Sheets("Append_Data")

ws1.UsedRange.Offset(1).Clear

Application.ScreenUpdating = False

For Each ws In Worksheets
      If ws.Name <> "Append_Data" Then
      ws.UsedRange.Offset(1).Copy ws1.Range("A" & Rows.Count).End(3)(2)
      End If
Next ws

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

You should find it to be somewhat quicker and there will be less drain on resource.

Test it in a copy of your actual workbook first.

Just an option for you.

Cheerio,
vcoolio.

 

[Philip1957]

vcoolio,

Thank you very much for the response. I hope someday my code will be as tight as yours! Practice, practice, practice ...

Your code worked exactly as you described. However, I won't always use it on the same workbook and need to store it in my personal.xlbs, so I made some changes.

Sub ConShtsRow()

Dim response
response = MsgBox("This will copy all of the data on all of the worksheets onto a new worksheet named Consolidated." & Chr(10) & _
    "The workbook must contain only worksheets with data.  If your workbook has non-data sheets, copy the data sheets you wish to consolidate into a new workbook" & Chr(10) & "All worksheets must have the same headers, and they must be in row 1.", _
vbOKCancel, "Warning")
If response = vbCancel Then
Exit Sub
End If

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Consolidated"

Dim ws As Worksheet, ws1 As Worksheet
Set ws1 = Sheets("Consolidated")

ws1.UsedRange.Offset(1).Clear

Application.ScreenUpdating = False

For Each ws In Worksheets
      If ws.Name <> "Consolidated" Then
      ws.UsedRange.Offset(1).Copy ws1.Range("A" & Rows.Count).End(3)(2)
      End If
Next ws

Sheets(1).Range("A1").EntireRow.Copy
ActiveSheet.Paste Destination:=Worksheets("Consolidated").Range("A1").EntireRow
 
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

This does exactly what I need it to do. The message box is to remind me of the conditions under which it can be used.

Thanks again,
~ Phil

 

[vcoolio]

Excellent Phil!
I'm glad that its all sorted out for you and I'm glad that I was able to help in some way.

Cheerio,
vcoolio.

 

[claudia80]

Hello
you could insert a sample file with the built-in macro. Thank you

 

[MRDecarte]

Hello
you could insert a sample file with the built-in macro. Thank you

Hello,

Would it possible to insert the file with the built-in code?
I also try to append rows from different sheets in one single sheet and I would appreciate some help to set up the code.
Thank you for the help much appreciated

 

[vcoolio]

Good day Claudia and MRDecarte,

Please start your own threads and include full descriptions of what you are trying to achieve. Also, it is always a good idea to upload a sample of your actual workbook so that we have something to test with and can better understand your issues.
You can upload a sample to a free file sharing site such as Drop Box then post the link to your file in your opening post. Make sure that the sample is an exact replica of your workbook and please use dummy data should your actual data be sensitive. A few rows of data per sheet will suffice.

Cheerio,
vcoolio.

 

[claudia80]

I kindly ask you to insert a file with the embedded code. I do not know which part of the code to insert in the module .. I would like to try the macro but if you do not insert a file I will not be able to do it ...
Thank you

 

[vcoolio]

.....................which is why I have asked that you upload a sample of your own workbook to your own thread. We can then show you how in your own workbook.

Cheerio,
vcoolio.