VBA复制粘贴循环

Question

I am trying to loop through four tabs, copying data from three input tabs and pasting it into the remaining, master, tab. The code should loop through all the column headings on the master tab, find whether the same heading exists in any of input tabs and, if it does, copy and paste the data into the relevant column of the master tab.

At the moment, I have got all the data from the first input tab into the master tab but I am having difficulties getting data from the remaining input tabs to paste below the data from the first input tab.

This is the code as it stands at the moment:

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    

At the moment, this section of code:

    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

Seems to be selecting the correct range on the correct sheet and copying it. The lastrow variable seems to be picking up the correct row on the master tab but the data is not pasted. I've tried naming the ranges and using Cells() rather than Range() but neither appeared to work. Any ideas as to how to get the data to paste would be much appreciated. Cheers, Ant

Answer 1

What I did was make a function that would find the column header and return the data range from from that column.

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