Consolidate Merge multiple worksheets into one master sheet using VBA

[KlausW]

Hi

I have a challenge. I use this VBA code to gather data from multiple sheets.
The data I want to collect is in column K to column S and all the way down.
I would like to have them put into Sheets Bestilling and start at cell A9.
possible only to copy numbers and text so that the formulas do not come with.

All help will be appreciated.

Best Regartds
Klaus W

Sub Rektangelafrundedehjørner1_Klik()
Dim startRow, startCol, lastRow, lastCol As Long
Dim headers As Range

'Set Master sheet for cosolidation
Set mtr = Worksheets("Master")

Set wb = ThisWorkbook
'Get Headers
Set headers = Range("k2")
Set headers = Application.Range("k2")
'InputBox("Select the Headers", Type:=8)

headers.Copy mtr.Range("k2")
startRow = headers.Row + 1
startCol = headers.Column

Debug.Print startRow, startCol
'loop through all sheets
For Each ws In wb.Worksheets
     'except the master sheet from looping
     If ws.Name <> "Master" Then
        ws.Activate
        lastRow = Cells(Rows.Count, startCol).End(xlUp).Row
        lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
        'get data from each worksheet and copy it into Master sheet
        Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
        mtr.Range("A" & mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1)
     End If
Next ws
Worksheets("Master").Activate
End Sub

 

[NdNoviceHlp]

Hi KlausW. Seems like U just need to change this line of code....

Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
        mtr.Range("A" & mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1)

to....

.Range(.Cells(startRow, "K"), .Cells(lastRow, "S")).Copy mtr.Range("A" & 9)

HTH. Dave

 

[NdNoviceHlp]

Ignore that last post. It seems like this should work. Please save a back up wb before trialling the code. HTH. Dave

Sub Rektangelafrundedehjørner1_Klik()
Dim startRow As Double, startCol As Double, DestlastRow As Double
Dim CopylastRow As Double, headers As Range
'K to S from all sheets to A9
'Set Bestilling sheet for cosolidation
Set mtr = Worksheets("Bestilling")

Set wb = ThisWorkbook
'Get Headers
Set headers = mtr.Range("k2")
'Set headers = Application.Range("k2")
'InputBox("Select the Headers", Type:=8)
'headers.Copy mtr.Range("k2")
startRow = headers.Row + 1
startCol = headers.Column
'Debug.Print startRow, startCol
'loop through all sheets
For Each ws In wb.Worksheets
     'except the Bestilling sheet from looping
     If ws.Name <> "Bestilling" Then
        ws.Activate
        If DestlastRow = 0 Then
        DestlastRow = 9
        Else
        DestlastRow = mtr.Range("A" & mtr.Rows.Count).End(xlUp).Row
        End If
        CopylastRow = ws.Range(startCol & ws.Rows.Count).End(xlUp).Row
        'get data from each worksheet and copy it into Bestilling sheet
        ws.Range(ws.Cells(startRow, startCol), ws.Cells(CopylastRow, "S")).Copy _
        mtr.Range("A" & DestlastRow + 1)
     End If
Next ws
Worksheets("Bestilling").Activate
End Sub

 

[KlausW]

Ignore that last post. It seems like this should work. Please save a back up wb before trialling the code. HTH. Dave

Sub Rektangelafrundedehjørner1_Klik()
Dim startRow As Double, startCol As Double, DestlastRow As Double
Dim CopylastRow As Double, headers As Range
'K to S from all sheets to A9
'Set Bestilling sheet for cosolidation
Set mtr = Worksheets("Bestilling")

Set wb = ThisWorkbook
'Get Headers
Set headers = mtr.Range("k2")
'Set headers = Application.Range("k2")
'InputBox("Select the Headers", Type:=8)
'headers.Copy mtr.Range("k2")
startRow = headers.Row + 1
startCol = headers.Column
'Debug.Print startRow, startCol
'loop through all sheets
For Each ws In wb.Worksheets
     'except the Bestilling sheet from looping
     If ws.Name <> "Bestilling" Then
        ws.Activate
        If DestlastRow = 0 Then
        DestlastRow = 9
        Else
        DestlastRow = mtr.Range("A" & mtr.Rows.Count).End(xlUp).Row
        End If
        CopylastRow = ws.Range(startCol & ws.Rows.Count).End(xlUp).Row
        'get data from each worksheet and copy it into Bestilling sheet
        ws.Range(ws.Cells(startRow, startCol), ws.Cells(CopylastRow, "S")).Copy _
        mtr.Range("A" & DestlastRow + 1)
     End If
Next ws
Worksheets("Bestilling").Activate
End Sub

Ignore that last post. It seems like this should work. Please save a back up wb before trialling the code. HTH. Dave

Sub Rektangelafrundedehjørner1_Klik()
Dim startRow As Double, startCol As Double, DestlastRow As Double
Dim CopylastRow As Double, headers As Range
'K to S from all sheets to A9
'Set Bestilling sheet for cosolidation
Set mtr = Worksheets("Bestilling")

Set wb = ThisWorkbook
'Get Headers
Set headers = mtr.Range("k2")
'Set headers = Application.Range("k2")
'InputBox("Select the Headers", Type:=8)
'headers.Copy mtr.Range("k2")
startRow = headers.Row + 1
startCol = headers.Column
'Debug.Print startRow, startCol
'loop through all sheets
For Each ws In wb.Worksheets
     'except the Bestilling sheet from looping
     If ws.Name <> "Bestilling" Then
        ws.Activate
        If DestlastRow = 0 Then
        DestlastRow = 9
        Else
        DestlastRow = mtr.Range("A" & mtr.Rows.Count).End(xlUp).Row
        End If
        CopylastRow = ws.Range(startCol & ws.Rows.Count).End(xlUp).Row
        'get data from each worksheet and copy it into Bestilling sheet
        ws.Range(ws.Cells(startRow, startCol), ws.Cells(CopylastRow, "S")).Copy _
        mtr.Range("A" & DestlastRow + 1)
     End If
Next ws
Worksheets("Bestilling").Activate
End Sub

Hi NdNoviceHlpI got an error in this line CopylastRow = ws.Range(startCol & ws.Rows.Count).End(xlUp).Row

 

[NdNoviceHlp]

Hmmm. Maybe should be....

CopylastRow = ws.Name.Range(startCol & ws.Name.Rows.Count).End(xlUp).Row
ws.Name.Range(ws.Name.Cells(startRow, startCol), ws.Name.Cells(CopylastRow, "S")).Copy _
        mtr.Range("A" & DestlastRow + 1)

Dave

 

[NdNoviceHlp]

One more try. I've finished my coffee...

CopylastRow =Sheets(ws.Name).Range(startCol & Sheets(ws.Name).Rows.Count).End(xlUp).Row
Sheets(ws.Name).Range(Sheets(ws.Name).Cells(startRow, startCol), Sheets(ws.Name).Cells(CopylastRow, "S")).Copy _
        mtr.Range("A" & DestlastRow + 1)

Dave

 

[KlausW]

One more try. I've finished my coffee...

CopylastRow =Sheets(ws.Name).Range(startCol & Sheets(ws.Name).Rows.Count).End(xlUp).Row
Sheets(ws.Name).Range(Sheets(ws.Name).Cells(startRow, startCol), Sheets(ws.Name).Cells(CopylastRow, "S")).Copy _
        mtr.Range("A" & DestlastRow + 1)

Dave

Hi Dave, I unfortunately got error in the same line CopylastRow = Sheets(ws.Name).Range(startCol & Sheets(ws.Name).Rows.Count).End(xlUp).Row KW

 

[KlausW]

Hi Dave
I found this code on the web it does the same thing I would like a VBA code for. There's only one thing I would hear you would help me with, if you do not have time or do not want, I will put it up as a question.
When I run the code delete the whole sheet, I wish it did not.
Best regards and good weekend Klaus W

Sub Rektangelafrundedehjørner1_Klik()
'Procedure to Consolidate all sheets in a workbook

On Error GoTo IfError

'1. Variables declaration
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

'2. Disable Screen Updating - stop screen flickering
'   And Disable Events to avoid inturupted dialogs / popups
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

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

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

'5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name <> DstSht.Name Then
       '5.1: Find the last row on the 'Consolidate_Data' sheet
       DstRow = fn_LastRow(DstSht)
       
               
       '5.2: Find Input data range
       LstRow = fn_LastRow(Sht)
       LstCol = fn_LastColumn(Sht)
       EnRange = Sht.Cells(LstRow, LstCol).Address
       Set SrcRng = Sht.Range("a2:" & EnRange)
       
       '5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet
        If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
            MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
            GoTo IfError
        End If
                
      '5.4: Copy data to the 'consolidated_data' WorkSheet
        SrcRng.Copy Destination:=DstSht.Range("k" & DstRow + 1)
                
    End If

Next
'DstSht.Range("A1") = "You can place the headeing in the first row"

IfError:

'6. Enable Screen Updating and Events
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[NdNoviceHlp]

Hi Klaus. Apologies for the code error(s) and the delayed responding. This line of code is the only one that removes the sheet...

ActiveWorkbook.Sheets("Consolidate_Data").Delete

The code then creates a new sheet with the same name. It seems like U are missing the fn_lastrow and fn_lastcol functions? Anyways, I'm going to build a test wb to find out where the code I posted went wrong. I'll post later. Dave

 

[NdNoviceHlp]

The copylastrow code was wrong because the range setting requires a column letter not a column number. Anyways, this trialled code seems to work. Dave

Sub Rektangelafrundedehjørner1_Klik()
Dim startRow As Double, startCol As Double, DestlastRow As Double
Dim CopylastRow As Double, headers As Range
'K to S from all sheets to A9 of Bestilling sheet
'Set Bestilling sheet for cosolidation
Set mtr = Worksheets("Bestilling")
startRow = 2
On eror GoTo Erfix
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

For Each ws In ThisWorkbook.Worksheets
'except the Bestilling sheet from looping
If ws.Name <> "Bestilling" Then
CopylastRow = Sheets(ws.Name).Range("K" & Sheets(ws.Name).Rows.Count).End(xlUp).Row
If mtr.Range("A" & 9) = vbNullString Then
DestlastRow = 8
Else
DestlastRow = mtr.Range("A" & mtr.Rows.Count).End(xlUp).Row
End If
Sheets(ws.Name).Range(Sheets(ws.Name).Cells(startRow, "K"), _
                           Sheets(ws.Name).Cells(CopylastRow, "S")).Copy _
mtr.Range("A" & DestlastRow + 1)
End If
Next ws

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