VBA复制粘贴循环

Posted 2021-04-02

我试图遍历四个选项卡，从三个输入选项卡复制数据并将其粘贴到剩余的主，选项卡中。代码应遍历主选项卡上的所有列标题，查找任何输入选项卡中是否存在相同的标题，如果存在，则将数据复制并粘贴到主选项卡的相关列中。

目前，我已将第一个输入选项卡中的所有数据都输入到主选项卡中，但是我很难从剩余的输入选项卡中获取数据以粘贴到第一个输入选项卡中的数据下方。

这是目前的代码：

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()，但似乎都不起作用。关于如何将数据粘贴的任何想法都将非常感激。干杯，蚂蚁

答案

我所做的是创建一个函数，找到列标题并返回该列的数据范围。

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