I am trying to copy data from multiple sheets and paste it into Sheet1. The result paste it into Sheet1 but the same row each time and not the next row of previous copied data. Here is my code. Any help is really appreciate. Thank you!

Sub LoopCopySheetsData() 

Dim i As Integer
Dim wb As Workbook
Dim totalWS As Long

Set wb = ActiveWorkbook
'totalWS = wb.Sheets.Count
totalWS = 4
For i = 2 To totalWS 'Start of the VBA loop

If i < totalWS   1 Then

Sheets(i).Select

With wb.Sheets(i)
Set findHeadRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues)
End With
headRow = findHeadRow.Row
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets(i).Range("A" & headRow   1 & ":A" & lastRow).Copy
Range("A1").Activate

With wb.Sheets("Sheet1")
lastRowMaster = Cells(Rows.Count, "D").End(xlUp).Row
Sheets("Sheet1").Range("D" & lastRowMaster   1).PasteSpecial xlPasteValues
End With

End If
Next i

End Sub

CodePudding user response：

Copy Columns From Multiple Worksheets

• If the header cell (Data) contains a formula, you will have to use xlValues instead of xlFormulas (first occurrence).
• Adjust the values in the constants section.

Option Explicit

Sub LoopCopySheetsData()
    
    ' Source
    Const sCol As String = "A"
    Const sHeader As String = "Data"
    ' Destination
    Const dName As String = "Sheet1"
    Const dCol As String = "D"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range
    Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
    
    Dim sws As Worksheet
    Dim srg As Range ' Range
    Dim shCell As Range ' Header Cell
    Dim slCell As Range ' Last Cell
    Dim rCount As Long ' Source/Destination Rows Count
    
    For Each sws In wb.Worksheets
        If StrComp(sws.Name, dName, vbTextCompare) <> 0 Then ' exclude 'dws'
            ' Find header cell and last cell.
            With sws.Columns(sCol)
                Set shCell = _
                    .Find(sHeader, .Cells(.Cells.Count), xlFormulas, xlWhole)
                Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
            End With
            If Not shCell Is Nothing Then
                If Not slCell Is Nothing Then
                    rCount = slCell.Row - shCell.Row ' without header
                    If rCount > 0 Then
                        Set srg = shCell.Offset(1).Resize(rCount)
                        dfCell.Resize(rCount).Value = srg.Value ' copy
                        Set dfCell = dfCell.Offset(rCount) ' next
                    End If
                End If
            End If
        End If
    Next sws

    MsgBox "Done.", vbInformation

End Sub

CodePudding user response：

Please heed this post: How to avoid using Select in Excel VBA. As second answer mentions, avoid any use of ActiveWorkbook, Activate, and Select for efficiency, maintenance, and readability.

Instead, explicitly qualify all Workbook, Worksheet, Cells, Range, and other objects. In fact, consider range assignment and avoid the need of copy and paste:

Sub LoopCopySheetsData() 
    Dim i As Integer, totalWS As Integer
    Dim headRow As Long, lastRow As Long, headRowMaster As Long, lastRowMaster As Long

    'totalWS = ThisWorkbook.Sheets.Count
    totalWS = 4
    For i = 2 To totalWS
        If i < (totalWS   1) Then

            With ThisWorkbook.Sheets(i)
                headRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues).Row
                lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            End With

            With ThisWorkbook.Sheets("Sheet1")
                headRowMaster = .Cells(.Rows.Count, "D").End(xlUp).Row
                lastRowMaster = headRowMaster   (lastRow - headRow)

                ' ASSIGN VALUES BY RANGE
                .Range("D" & headRowMaster   1 & ":D" & lastRowMaster).Value = _
                    ThisWorkbook.Sheets(i).Range("A" & headRow   1 & ":A" & lastRow).Value
            End With

        End If
    Next i
End Sub