Code is only pasting header row into master sheet

[Svandra]

So, I have a workbook with a varying number of sheets. All have the same structure, number of columns, headers. What I want to do is put all the sheets together in 1 sheet. I've tried several codes but this one is the only one that doesn't give me an error message. However, it's only pasting the header lines and not pasting any of the data. But I want only 1 header line AND all the data from the other sheets in the master sheet. Can anyone help???

Sub CopyFromWorksheets()
    Dim wrk As Workbook 'Workbook object 
    Dim sht As Worksheet 
    Dim trg As Worksheet 
    Dim rng As Range
    Dim colCount As Integer 
     
    Set wrk = ActiveWorkbook     

    Application.ScreenUpdating = False
     
  
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.count))
    trg.name = "Master"
    Set sht = wrk.Worksheets(1)
    colCount = sht.Cells(1, 255).End(xlToLeft).Column
    With trg.Cells(1, 1).Resize(1, colCount)
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value
         'Set font as bold
        .Font.Bold = True
    End With
     

    For Each sht In wrk.Worksheets
        If sht.Index = wrk.Worksheets.count Then
            Exit For
        End If
   
        Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.ROWS.count, rng.Columns.count).Value = rng.Value
    Next sht
    
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Try:

Sub CopyFromWorksheets()
    Application.ScreenUpdating = False
    Dim x As Long, lCol As Long
    lCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set trg = Sheets.Add(After:=Sheets(Sheets.Count))
    trg.Name = "Master"
    For x = 1 To Sheets.Count - 1
        If x = 1 Then
            Sheets(x).UsedRange.Copy trg.Range("A1")
        Else
            Sheets(x).UsedRange.Offset(1).Copy trg.Cells(trg.Rows.Count, "A").End(xlUp).Offset(1)
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[Svandra]

Try:

Sub CopyFromWorksheets()
    Application.ScreenUpdating = False
    Dim x As Long, lCol As Long
    lCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set trg = Sheets.Add(After:=Sheets(Sheets.Count))
    trg.Name = "Master"
    For x = 1 To Sheets.Count - 1
        If x = 1 Then
            Sheets(x).UsedRange.Copy trg.Range("A1")
        Else
            Sheets(x).UsedRange.Offset(1).Copy trg.Cells(trg.Rows.Count, "A").End(xlUp).Offset(1)
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

This code kind of works. It's copy/pasting the header properly. However, it's not getting all the data from all the sheets. For example, there are 600+ rows in the sheet that lists 'Bayern' but the code only pastes these few lines (see image)? Also, there are those empty lines in between.

 

[mumps]

Try:

Sub CopyFromWorksheets()
    Application.ScreenUpdating = False
    Dim x As Long, lCol As Long, lRow As Long
    lCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set trg = Sheets.Add(After:=Sheets(Sheets.Count))
    trg.Name = "Master"
    For x = 1 To Sheets.Count - 1
        lRow = Sheets(x).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If x = 1 Then
            Sheets(x).Range("A1:A" & lRow).Resize(, lCol).Copy trg.Range("A1")
        Else
            Sheets(x).Range("A2:A" & lRow).Resize(, lCol).Copy trg.Cells(trg.Rows.Count, "A").End(xlUp).Offset(1)
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[Herakles]

Try this.

Public Sub subCopySheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
        
    Set wrk = ActiveWorkbook
    
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
    
    trg.Name = "Master"
    
    Sheets(1).Rows(1).EntireRow.Copy trg.Range("A1")
        
    For Each sht In wrk.Worksheets
        
        If sht.Name <> "Master" Then
        
            With sht.UsedRange
                
                .Offset(1, 0).Copy Worksheets("Master").Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
                
            End With
        
        End If
   
    Next sht
    
End Sub

 

[Svandra]

This code works, it pastes all sheets but it starts at I1 not A1?

Sub CopyToMaster()
 
ShtCount = ActiveWorkbook.Sheets.count
 
For i = 2 To ShtCount
 
Worksheets(i).Activate
lastRow = activeSheet.Cells(ROWS.count, "K").End(xlUp).row
 
Range("A2:K" & lastRow).Select
 
Selection.Copy
Sheets("Master").Activate
 
lastRow = activeSheet.Cells(ROWS.count, "K").End(xlUp).Select
 
'Required after first paste to shift active cell down one
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
 
ActiveCell.Offset(0, -3).Select
Selection.PasteSpecial
 
 
Next i
End Sub

 

[Svandra]

Try this.

Public Sub subCopySheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
       
    Set wrk = ActiveWorkbook
   
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
   
    trg.Name = "Master"
   
    Sheets(1).Rows(1).EntireRow.Copy trg.Range("A1")
       
    For Each sht In wrk.Worksheets
       
        If sht.Name <> "Master" Then
       
            With sht.UsedRange
               
                .Offset(1, 0).Copy Worksheets("Master").Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
               
            End With
       
        End If
  
    Next sht
   
End Sub

This one kind of works but doesn't copy all the sheets and all the data

 

[Herakles]

This one kind of works but doesn't copy all the sheets and all the data

Do the sheets that it does not copy have anything in common?

How many sheets do you have?

 

[mumps]

Did you try the code I suggested in Post #4?

 

[Svandra]

Do the sheets that it does not copy have anything in common?

How many sheets do you have?

The sheets all have the same structure, number of columns and headers. In total, it's 16 sheets.