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

 

[sja]

Thank you. I seem to be getting somewhere now.. I just need to combine your code with the original post code.. If you could suggest how that would be great no problem if not.. Thsk you again..

 

[jindon]

What is your original code?

 

[sja]

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

 

[pfarmer]

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

How are the sheets named. You state 'second sheet'. Is this the second sheet in the order of tabs (which can be changed) or is this the second sheet such as sheet1, sheet2?

Perry

 

[jindon]

does this do the job?

Sub Sample()
Dim wsR As worksheet, i As Integer, flg As Boolean
On Error Resume Next
With ThisWorkbook
     .Sheets("Combined").Delete
On Error GoTo 0
     Set wsR = .Sheets.Add(After:=.Sheets(.Sheets.Count))
     For i = 2 To .Sheets.Count - 1
          If Not flg Then
               wsR.Rows(1).Value = .Sheets(i).Rows(1).Value
                   With wsR
                         .Columns(1).Insert
                         With .Cells(1,1)
                                .Value = "Contractor"
                                .FontBold = Tue
                         End With
                         With .Cells(1,7)
                                 .Value = "Contractor List"
                                 .Font.Bold = True
                         End With
                   End With
               flg = True
          End If
          With .Sheets(i).Range("a1").CurrentRegion
                 With .Resize(.Rows.Count - 1).Offset(1)
                      wsR.Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count,.Columns.Count).Value = .Value
                 End With
          End With
     Next
End With
End Sub

note: code edited

 

[sja]

No I get a debug error on line

With .Resize(.Rows.Count - 1).Offset(1)

 

[jindon]

change

With .Sheets(i).Range("a1").CurrentRegion

To

With .Sheets(i).Range("a3").CurrentRegion

 

[sja]

Using this code, works ok BUT, if I only want to copy data from cell b30. If one of my sheets has this cell/ row empty the code copies the line above (which is populated).

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

Can it be amended?

Thank you

 

[jindon]

OK, ref to your PM
is this what you want?

Sub Sample()
Dim i As Integer, LastR As Range
For i = 2 To ThisWorkbook.Sheets.Count
    With Sheets(i)
            Set LastR = .Range("b" & Rows.Count).End(xlUp)
            If LastR.Row > 30 Then
               .Range("b30",LastR).Resize(,8).Copy _
               Sheets("Steve").Range("z" & Rows.Count).End(xlUp).Offset(1)
            End If
    End With
Next
End Sub

 

[sja]

It nearly works but only brings data from one or two sheets and misses the others out..Depiste tmeh haing a record in row 30? Strange..