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

VBA复制粘贴循环

1 个答案: