VBA復制粘貼循環

Question

我試圖遍歷四個選項卡，從三個輸入選項卡復制數據並將其粘貼到其余的主選項卡中。 該代碼應循環瀏覽主選項卡上的所有列標題，查找任何輸入選項卡中是否存在相同的標題，如果存在，則將數據復制並粘貼到主選項卡的相關列中。

目前，我已將所有數據從第一個輸入選項卡放入主選項卡，但是我很難從其余輸入選項卡中獲取數據並粘貼到第一個輸入選項卡的數據下方。

這是目前的代碼：

Sub master_sheet_data()

Application.ScreenUpdating = False

'Variables
Dim ws1_xlRange As Range
Dim ws1_xlCell As Range
Dim ws1 As Worksheet

Dim ws2_xlRange As Range
Dim ws2_xlCell As Range
Dim ws2 As Worksheet

Dim ws3_xlRange As Range
Dim ws3_xlCell As Range
Dim ws3 As Worksheet

Dim ws4_xlRange As Range
Dim ws4_xlCell As Range
Dim ws4 As Worksheet

Dim valueToFind As String
Dim lastrow As String
Dim lastrow2 As String
Dim copy_range As String

'Assign variables to specific worksheets/ranges
'These will need to be updated if changes are made to the file.
Set ws1 = ActiveWorkbook.Worksheets("Refined event data - all")
Set ws1_xlRange = ws1.Range("A1:BJ1")

Set ws2 = Worksheets("Refined event data")
Set ws2_xlRange = ws2.Range("A1:BJ1")

Set ws3 = Worksheets("Refined MASH data")
Set ws3_xlRange = ws3.Range("A1:BJ1")

Set ws4 = Worksheets("Raw RHI data - direct referrals")
Set ws4_xlRange = ws4.Range("A1:BJ1")

'Loop through all the column headers in the all data tab
For Each ws1_xlCell In ws1_xlRange
    valueToFind = ws1_xlCell.Value
        'Loop for - Refined event data tab
        'check whether column headers match. If so, paste column from event tab to relevant column in all data tab
        For Each ws2_xlCell In ws2_xlRange
            If ws2_xlCell.Value = valueToFind Then
                ws2_xlCell.EntireColumn.Copy
                ws1_xlCell.PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next ws2_xlCell
        'Loop for - Refined ID data tab
        'check whether column headers match. If so, paste column from MASH tab to the end of relevant column in all data tab
        For Each ws3_xlCell In ws3_xlRange
            If ws3_xlCell.Value = valueToFind Then
                Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy
                lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
                Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next ws3_xlCell
        'Loop for - direct date data tab
        'check whether column headers match. If so, paste column from direct J4U tab to the end of relevant column in all data tab
        For Each ws4_xlCell In ws4_xlRange
            If ws4_xlCell.Value = valueToFind Then
                Range(ws4_xlCell.Address(), ws4_xlCell.End(xlDown).Address()).Copy
                lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
                Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next ws4_xlCell

Next ws1_xlCell
End Sub    

目前，這段代碼：

    For Each ws3_xlCell In ws3_xlRange 
If ws3_xlCell.Value = valueToFind Then 
Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy 
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats 
End If 
Next ws3_xlCell

似乎是在正確的紙張上選擇正確的范圍並進行復印。 lastrow變量似乎正在選擇“主”選項卡上的正確行，但未粘貼數據。 我試圖命名范圍並使用Cells()而不是Range()但是都沒有起作用。 任何有關如何獲取粘貼數據的想法將不勝感激。 干杯，螞蟻

Answer 1

我所做的是創建一個函數，該函數將查找列標題並從該列返回數據范圍。

Sub master_sheet_data()

    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim cell As Range, source As Range, target As Range

    With ThisWorkbook.Worksheets("Raw RHI data - direct referrals")
        For Each ws In Worksheets(Array("Refined event data - all", "Refined event data", "Refined MASH data"))
            For Each cell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
                Set source = getColumnDataBodyRange(ws, cell.Value)
                If Not source Is Nothing Then
                    Set target = cell.Offset(.Rows.Count - 1).End(xlUp).Offset(1)
                    source.Copy
                    target.PasteSpecial xlPasteValuesAndNumberFormats
                End If
            Next
        Next
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Function getColumnDataBodyRange(ws As Worksheet, ColumnHeader As Variant) As Range
    Dim cell As Range
    With ws
        Set cell = .Rows(1).Find(What:=ColumnHeader, After:=.Range("A1"))
        If Not cell Is Nothing Then
            Set getColumnDataBodyRange = .Range(cell.Offset(1), cell.Offset(.Rows.Count - 1).End(xlUp))
        End If
    End With
End Function