Consolidate Merge multiple worksheets into one master sheet using VBA

KlausW

Board Regular
Joined
Sep 9, 2020
Messages
159
Office Version
  1. 2016
Platform
  1. Windows
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

VBA Code:
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
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,839
Hi KlausW. Seems like U just need to change this line of code....
Code:
Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
        mtr.Range("A" & mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1)
to....
Code:
.Range(.Cells(startRow, "K"), .Cells(lastRow, "S")).Copy mtr.Range("A" & 9)
HTH. Dave
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,839
Ignore that last post. It seems like this should work. Please save a back up wb before trialling the code. HTH. Dave
Code:
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

Board Regular
Joined
Sep 9, 2020
Messages
159
Office Version
  1. 2016
Platform
  1. Windows
Ignore that last post. It seems like this should work. Please save a back up wb before trialling the code. HTH. Dave
Code:
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
Code:
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,839

ADVERTISEMENT

Hmmm. Maybe should be....
Code:
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,839
One more try. I've finished my coffee...
Code:
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

Board Regular
Joined
Sep 9, 2020
Messages
159
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

One more try. I've finished my coffee...
Code:
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

Board Regular
Joined
Sep 9, 2020
Messages
159
Office Version
  1. 2016
Platform
  1. Windows
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

VBA Code:
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,839
Hi Klaus. Apologies for the code error(s) and the delayed responding. This line of code is the only one that removes the sheet...
Code:
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,839
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
Code:
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
 

Forum statistics

Threads
1,144,281
Messages
5,723,473
Members
422,499
Latest member
think say

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top