Copy data from multiple sheet and paste into 1 sheet - excel

Question

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

Answer 1

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

Answer 2

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