复制有1的那一列旁边的值，然后粘贴到另一个sheet的多个地方，逐一循环

Question

我的宏的逻辑应该是：

我有 2 个列

第 1 栏	第 2 栏
DHBE	1
DHEU	0
SJER	1

如果第 2 列中有一个 1，则将第 1 列中的文本粘贴到另一个 tab/sheet。 例如

DHBE - copy & go to sheet("Template").select, Paste in Rows "I4:I549"
Select Range E4:R549.copy
sheet("Volume").select, Paste under last row, starting in column A

skip DHEU

SJER - copy & go to sheet("Template").select, Paste in Rows "I4:I549"
Select Range E4:R549.copy
sheet("Volume").select, Paste under last row, starting in column A

问题：宏一次循环遍历第1列中的所有数据，我希望它一个一个循环遍历并复制到不同列中的不同tab/sheet？

Sub Config()  
    Dim c As Range
    Dim Rng1 As Range
    Sheets("Upload Config").Select
    
    tr = Columns(1).Rows.Count
    
    Set Rng1 = Range("B4:B" & tr)
    
    For Each c In Rng1
    
        If c.Value = "1" Then
        
            c.Offset(0, -1).Copy
            
            

            'Option 1

            'Destination:=Range("b" & tr).End(xlUp).Offset(1, 0)

            'Option 2

            Range("a32").PasteSpecial Paste:=xlPasteValues


        End If
    Next c

End Sub

Answer 1

我会执行以下操作，这比复制每个值要快得多：

首先我们将所有数据加载到一个数组中，因为数组处理比处理范围快得多。然后我们检查输出中需要哪些数据并将其收集到一个集合中。然后我们将他收集的数据写到一个二维输出数组中，这个数组可以很容易地写入一个范围：

Option Explicit

Public Sub Config()
    Dim ws As Worksheet  ' define worksheet
    Set ws = ThisWorkbook.Worksheets("Upload Config")
    
    Dim LastRow As Long  ' get last used row in column A
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim DataRange As Range  ' get data range A1:B3
    Set DataRange = ws.Range("A1", "B" & LastRow)
    
    Dim DataArray() As Variant  ' read data into an array (for fast processing)
    DataArray = DataRange.Value
    
    Dim OutputData As Collection  ' create a collection where we collect all desired data
    Set OutputData = New Collection
    
    ' check each data row and if desired add to collection
    Dim iRow As Long
    For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
        If DataArray(iRow, 2) = 1 Then
            OutputData.Add DataArray(iRow, 1)
        End If
    Next iRow
    
    ' create an output array of the size of collected data
    Dim OutputArray() As Variant
    ReDim OutputArray(1 To OutputData.Count, 1 To 1)
    
    ' turn collection into an 2 dimensional array (that we can write to a range)
    Dim i As Long
    For i = 1 To OutputData.Count
        OutputArray(i, 1) = OutputData.Item(i)
    Next i
    
    ' write the array data to a range
    ws.Range("D1").Resize(RowSize:=OutputData.Count).Value = OutputArray
End Sub

结果将从D1往下写

_{图1：输出数据为红色，输入数据为黑色。}

---

// 编辑

Option Explicit

Public Sub Config()
    Dim ws As Worksheet  ' define worksheet
    Set ws = ThisWorkbook.Worksheets("Upload Config")
    
    Dim LastRow As Long  ' get last used row in column A
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim DataRange As Range  ' get data range A1:B3
    Set DataRange = ws.Range("A1", "B" & LastRow)
    
    Dim DataArray() As Variant  ' read data into an array (for fast processing)
    DataArray = DataRange.Value
    
    Dim OutputData As Collection  ' create a collection where we collect all desired data
    Set OutputData = New Collection
    
    ' check each data row and if desired add to collection
    Dim iRow As Long
    For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
        If DataArray(iRow, 2) = 1 Then
            OutputData.Add DataArray(iRow, 1)
        End If
    Next iRow
    
    
    Dim wsTemplate As Worksheet
    Set wsTemplate = ThisWorkbook.Worksheets("Template")
    
    Dim wsVolume As Worksheet
    Set wsVolume = ThisWorkbook.Worksheets("Volume")
    
    ' loop through your collection and do the copy stuff
    Dim i As Long
    For i = 1 To OutputData.Count
        wsTemplate.Range("I4:I549").Value = OutputData.Item(i) ' write values DHBE, SJER
        Dim SourceRange As Range
        Set SourceRange = wsTemplate.Range("E4:R549")
        
        ' copy values from source range to sheet volume last row
        wsVolume.Cells(wsVolume.Rows.Count, "A").End(xlUp).Offset(RowOffset:=1).Resize(RowSize:=SourceRange.Rows.Count, ColumnSize:=SourceRange.Columns.Count).Value = SourceRange.Value
    Next i
End Sub