Copy the value next to the column that has 1, and paste it to multiple places in another sheet, looping through one by one

The logic of my Macro is supposed to be:

I have 2 colums

Column 1	Column 2
DHBE	1
DHEU	0
SJER	1

If in Column 2, there is a 1, then take the text from Column 1 and paste it into another tab/sheet. e.g.

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

Question: The Macro loops through all the data in Column 1 at once, I would like it to loop through it one by one and copy it in a different tab/sheet in different columns?

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

Solution

I would do the following which is much faster than copying each value:

First we load all data into an array because array processing is much faster than processing ranges. Then we check wich data needs to be in the output and collect it in a collection. Then we write he collected data into a 2 dimensional output array that can easily be written into a range:

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

The result will be written from D1 downwards.

_{Image 1: Output data in red, input data in black.}

// edit

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