trying to consolidate multiple sheets into one sheet

[shortaznkid4]

Help!

I'm trying to compile a list of data from multiple sheets into one sheet. All the sheets are formatted the same way. I found a code online that does this but its tailored so that the header starts in cell A1. I got it to work with the headers starting in cell a2 but can't get it to work from a3 down.

Here is the link for the code I found

http://www.get-digital-help.com/2010/03/29/consolidate-sheets-in-excel-vba/


the code is as follows:

Option Explicit
Sub Consolidate()
Application.ScreenUpdating = False
'Dim
Dim csShts As Range
Dim clmnheader As Range
Dim sht As Worksheet
Dim LastRow As Integer
Dim i As Long
Set csShts = Worksheets("Consolidate").Range("A2")
' Change this range (D1)!!!!!!!
Set clmnheader = Worksheets("Consolidate").Range("B1")
'Iterate sheet cells on sheet "consolidate"
Do While csShts <> ""
' Iterate all sheets to find a match between sht and csShts
For Each sht In Worksheets

'Find a matching sheet

i = 0
If sht.Name = csShts Then

'Select sheet
sht.Select

'Select cell A1 on sheet
Range("A1").Select

'Iterate columnheaders on sheet

Do While Selection <> ""
'Iterate column headers on consolidate sheet

Set clmnheader = Worksheets("Consolidate").Range("B1")

Do While clmnheader <> ""

'Find matching column headers on consolidate sheet against column headers on current sheet

If clmnheader.Value = Selection.Value Then

'Find last row in column

LastRow = ActiveSheet.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row

End If

'Save maximum last row number on current sheet

If LastRow > i Then

i = LastRow

End If

'Move to next column header on consolidate sheet

Set clmnheader = clmnheader.Offset(0, 1)

Loop

ActiveCell.Offset(0, 1).Select

Loop

sht.Select

Range("A1").Select

Set clmnheader = Worksheets("Consolidate").Range("B1")

'Iterate columnheaders from beginning on current sheet

Do While Selection <> ""

Set clmnheader = Worksheets("Consolidate").Range("B1")
'Iterate column headers on consolidate sheet

Do While clmnheader <> ""

If clmnheader.Value = Selection.Value Then

Set clmnheader = clmnheader.Offset(1, 0)

'Copy range

Do While Selection.Row <= i

ActiveCell.Offset(1, 0).Select

Selection.Copy

clmnheader.Insert Shift:=xlDown

Loop

ActiveCell.Offset(-i, 0).Select

Set clmnheader = clmnheader.Offset(-i, 0)

'Set clmnheader = clmnheader.End(xlUp)

End If

'Move to next column header on consolidate sheet

Set clmnheader = clmnheader.Offset(0, 1)



Loop

'Move to next cell on current sheet

ActiveCell.Offset(0, 1).Select

Loop

End If

Next sht

'Move to next cell
Set csShts = csShts.Offset(1, 0)
Loop
Sheets("Consolidate").Select
End Sub



Now how to I make it so that it extracts the data from everysheet starting with say, row 10. You can download the excel file from the link above too.
help please. I am an amateur with vba so this stuff is confusing.

 

[greegan]

Set clmnheader = Worksheets("Consolidate").Range("B1")

Wouldn't referencing B1 be counter productive to staring on row 2 or 3?
I'm not sure though. Just asking. Maybe something to think about?

-- g

 

[knighcloud]

You can also try to use this code:

Sub CopyDataWithHeaders()
    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

    
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Summary").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Summary"

    StartRow = 2

    For Each sh In ActiveWorkbook.Worksheets

        If sh.Name <> DestSh.Name Then
	    
	    'This is the range of your header, change to suit your needs
            If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
            sh.Range("A1:G1").Copy DestSh.Range("A1")
            End If

            Last = LastRow(DestSh)
            shLast = LastRow(sh)

            If shLast > 0 And shLast >= StartRow Then
		'This is the range of your data, change to suit your needs
                Set CopyRng = sh.Range("A2:G20")

                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "There are not enough rows in the Destsh"
                    GoTo ExitTheSub
                End If

                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With

            End If

        End If
    Next

ExitTheSub:

    Application.GoTo DestSh.Cells(1)

    DestSh.Columns.AutoFit

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

This creates a worksheet named "Summary" and consolidates all your data. The code copies the header only once.

Credit: Ron de Bruin

http://www.rondebruin.nl/tips.htm

 

[jbeaucaire]

One more...

'MANY SHEETS TO ONE SHEET
I have a macro that may be "almost ready to use" for merging data from multiple sheets into a "consolidation" sheet.

Sheets to One Sheets - Part 1​

The parts that may need editing are colored to draw your attention.

 

[Ron de Bruin]

I see that knighcloud forgot to past the function in his reply

See this page with all the info and a example workbook
http://www.rondebruin.nl/copy2.htm