Combine several Worksheet automatically with a macro?

[RCMetrics]

Hi,

say I have a workbook with 10-15 worksheets

All worksheets have the same headers, they just represent different locations.

What would be the code or macro to copy each one into one worksheet rather than copying and pasting everytime.

This is how the workbook is received and it's on a weekly basis... so getting anoying.

So it would go through each sheet, take line 2 to (what ever the amout there is in the worksheet) and get that into another one, then repeat the process for each worksheet till it has done all of them?

Thanks

 

[Norie]

Can you give more information?

The following is a generic solution supposing you want to copy all columns.

Sub Consolidate()
Dim wsSrc As Worksheet
Dim wsNew As Worksheet
Dim LastRowSrc As Long
Dim LastRowDst As Long

    Set wsNew = Worksheets.Add
    
    LastRowDst = 1
    
    For Each wsSrc In Worksheets
        If wsSrc.Name <> wsNew.Name Then
                
            LastRowSrc = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
        
            If LastRowDst = 1 Then
                wsSrc.Range("A1").Resize(LastRowSrc).EntireRow.Copy wsNew.Range("A" & LastRowDst)
                LastRowDst = LastRowDst + LastRowSrc
            Else
                wsSrc.Range("A2").Resize(LastRowSrc - 1).EntireRow.Copy wsNew.Range("A" & LastRowDst)
                LastRowDst = LastRowDst + LastRowSrc - 1
            End If
            
        End If
    Next wsSrc
End Sub

 

[RCMetrics]

Thanks...

It does what I was looking for.

Although I have a runtime error "400" after it ran

Thinking that I have a header not matching or something

So I'll investigate that but mainly, your code is doing what I was looking for...

Thanks.

 

[pfarmer]

Thanks...

It does what I was looking for.

Although I have a runtime error "400" after it ran

Thinking that I have a header not matching or something

So I'll investigate that but mainly, your code is doing what I was looking for...

Thanks.

Maybe something similar in concept. This takes the names of the tabs and then creates a master sheet with these tab names. It then takes the next three columns on each individual sheet starting at row 3 (first row of data) and puts these into the master sheet. I forget where I stole this from but I think it was here.

Sub CopyFromWorksheets()
    Dim wrk As Workbook 'Workbook object - Always good to work with object variables
    Dim sht As Worksheet 'Object for handling worksheets in loop
    Dim trg As Worksheet 'Master Worksheet
    Dim rng As Range 'Range object
    Dim colCount As Integer 'Column count in tables in the worksheets
    Dim n
    n = 1
    
    Set wrk = ActiveWorkbook 'Working in active workbook
     
     'We don't want screen updating
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
On Error Resume Next
    Sheets("Master").Delete

    Application.DisplayAlerts = True
     'Add new worksheet as the last worksheet
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
     'Rename the new worksheet
    trg.Name = "Master"
     'Get column headers from the first worksheet
     'Column count first
    Set sht = wrk.Worksheets(1)
    colCount = sht.Cells(1, 255).End(xlToLeft).Column + 3
     'Now retrieve headers, no copy&paste needed
    With trg.Cells(1, 2).Resize(1, colCount)
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value
        .Font.Bold = True
    End With
    trg.Cells(1, 1) = "Contractor"
    trg.Cells(1, 1).Font.Bold = True
    trg.Cells(1, 7) = "Contractor List"
    trg.Cells(1, 7).Font.Bold = True
        
     'We can start loop
    For Each sht In wrk.Worksheets
         'If worksheet in loop is the last one, stop execution (it is Master worksheet)
        If sht.Index = wrk.Worksheets.Count Then
            Exit For
        End If
        n = n + 1
         'Data range in worksheet - starts from third row as first rows are the header rows in all worksheets
        Set rng = sht.Range(sht.Cells(3, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))

         'Put data into the Master worksheet
        trg.Cells(65536, 2).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, 1).Value = sht.Name
    trg.Cells(n, 7).Value = sht.Name
    Next sht
     'Fit the columns in Master worksheet
    trg.Columns.AutoFit

    Range("G2").Select
    ActiveWindow.FreezePanes = True

     'Screen updating should be activated
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


   
End Sub

 

[sja]

Im really struggling changing this code so it does what I require. CAn any assist?

I need to change it so it ONLY takes data form the second sheet to the last. Also ONLY takes data form column B to Column I and row 30 till the last row with data in.

I have tried for hours to change it but have no reall experience in VBA.

Regards

Steve

 

[jindon]

try

Sub Sample()
Dim i As Integer
For i = 2 To ThisWorkbook.Sheets.Count
    With Sheets(i)
           .Range("b30",.Range("b" & Rows.Count).End(xlUp)).Resize(,8).Copy _
           Sheets(1).Range("a" & Rows.Count).End(xlUp).Offset(1)
    End With
Next
End Sub

 

[sja]

No the with worksheets (i) just gives an error!

 

[jindon]

change it to Sheets(i)

 

[sja]

Sorry still error, its in red in the VBA window..

 

[jindon]

If "." period at the end, please delete it..