VBA复制粘贴循环

佚名 2024-09-20 10:37:48 举报

篇首语：本文由小编为大家整理，主要介绍了VBA复制粘贴循环相关的知识，希望对你有一定的参考价值。

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

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

这是目前的代码：

Sub master_sheet_data()Application.ScreenUpdating = False"VariablesDim ws1_xlRange As RangeDim ws1_xlCell As RangeDim ws1 As WorksheetDim ws2_xlRange As RangeDim ws2_xlCell As RangeDim ws2 As WorksheetDim ws3_xlRange As RangeDim ws3_xlCell As RangeDim ws3 As WorksheetDim ws4_xlRange As RangeDim ws4_xlCell As RangeDim ws4 As WorksheetDim valueToFind As StringDim lastrow As StringDim lastrow2 As StringDim 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 tabFor 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_xlCellNext ws1_xlCellEnd 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 + 1Cells(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 = TrueEnd SubFunction 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 WithEnd Function

以上是关于VBA复制粘贴循环的主要内容，如果未能解决你的问题，请参考以下文章