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

 

[Svandra]

You could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

Here's the link: Example.xlsm | Powered by Box

 

[mumps]

This should do it:

Sub CopyFromWorksheets()
    Application.ScreenUpdating = False
    Dim x As Long, lCol As Long, lRow As Long, lRow2 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).Columns(2).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If x = 1 Then
            Sheets(x).Range("A1:A" & lRow).Resize(, lCol).Copy trg.Range("A1")
        Else
            lRow2 = trg.Columns(2).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            Sheets(x).Range("B2:B" & lRow).Resize(, lCol - 1).Copy trg.Range("B" & lRow2)
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[Svandra]

This should do it:

Sub CopyFromWorksheets()
    Application.ScreenUpdating = False
    Dim x As Long, lCol As Long, lRow As Long, lRow2 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).Columns(2).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If x = 1 Then
            Sheets(x).Range("A1:A" & lRow).Resize(, lCol).Copy trg.Range("A1")
        Else
            lRow2 = trg.Columns(2).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            Sheets(x).Range("B2:B" & lRow).Resize(, lCol - 1).Copy trg.Range("B" & lRow2)
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

This works brilliantly!! Thank you so much!!

 

[mumps]

You are very welcome.