根据条件复制/粘贴单元格范围 x 次

Question

I want to fill each empty cells of a board with a precise range of data.

I 've got two worksheets;

- worksheets("Board")

- worksheets("FinalBoard")

In worksheet worksheets("Board") I've got the following board ;

Category	Fruits-1	Fruits-2	Fruits-3
A	Banana	Cherries	Orange
D	Apple	Mango	Strawberries
B	Pineapple	Watermelon	Grenade

I want to pick each columns data only if the header starts with "Fruits" and paste them in one colum in worksheet worksheets("FinalBoard") . I was able to do so with columns named Fruits, with the following code;

Sub P_Fruits()

 Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim lRowInput As Long
    Dim lRowOutput As Long
    Dim lCol As Long
    Dim i As Long
    Dim n As Long
    Dim s As String
    Dim col As String
    
    '~~>  Sheets settings
    Set wsInput = Sheets("Board")
    Set wsOutput = Sheets("FinalBoard")

       
With wsInput
        '~~> Find last column in Row 2
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        '~~> loop through columns
        For i = 1 To lCol
            '~~>  research criterias
            If .Cells(1, i).Value2 Like "Fruit-*" Then
                '~~> Get columns name
                col = Split(.Cells(, i).Address, "$")(1)
                
                '~~> Get the last row in that column
                lRowInput = .range(col & .Rows.Count).End(xlUp).row
                
                '~~> Find the next row to write to
               If lRowOutput = 0 Then
                    lRowOutput = 2
               Else
                    lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
                End If
                
                '~~> Copy-paste in the 2nd worksheet every data if the headers is found
                .range(col & "2:" & col & lRowInput).Copy _
                wsOutput.range("B" & lRowOutput)
                
      
            End If
      Next i
end with

end sub 

however I'd like to do so for the column "category" and put the category's type in front of each fruits in column A and thus repeat the copied range category multiple time , as much as there were headers beginning with "Fruits" in worksheets("Board") . I tried to add an extra code to the previous one but it didnt work. Here is what I'd like as a result;

Category-pasted	Fruits-pasted
A	Banana
D	Apple
B	Pineapple
A	Cherries
D	Melon
B	Watermelon
A	Orange
D	Strawberries
B	Grenade

Here is what I had with the code I added instead...

Category-pasted	Fruits-pasted
	Banana
	Apple
	Pineapple
	Cherries
	Melon
	Watermelon
	Orange
	Strawberries
	Grenade
A
D
B

My finale code;

Sub Fruits_add()

 Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim lRowInput As Long
    Dim lRowOutput As Long
    Dim lCol As Long
    Dim i As Long
    Dim n As Long
    Dim s As String
    Dim col As String
    
    '~~>  Sheets settings
    Set wsInput = Sheets("Board")
    Set wsOutput = Sheets("FinalBoard")

       
With wsInput
        '~~> Find last column in Row 2
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        '~~> loop through columns
        For i = 1 To lCol
            '~~>  research criterias
            If .Cells(1, i).Value2 Like "Fruit-*" Then
                '~~> Get column name
                col = Split(.Cells(, i).Address, "$")(1)
                
                '~~> Get the last row in that column
                lRowInput = .range(col & .Rows.Count).End(xlUp).row
                
                '~~> Find the next row to write to
               If lRowOutput = 0 Then
                    lRowOutput = 2
               Else
                    lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
                End If
                
                '~~> Copy-paste
                .range(col & "2:" & col & lRowInput).Copy _
                wsOutput.range("B" & lRowOutput)
                
      
            End If
      Next i
      
 'Code to repeat category type added     
With wsInput
        '~~> Find last column in Row 2
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        '~~> loop through columns
        For i = 1 To lCol
        
         '~~>  research criterias
            If .Cells(1, i).Value2 Like "Category*" Then
                '~~> Get column name
                col = Split(.Cells(, i).Address, "$")(1)
                
                '~~> Get the last row in that column
                lRowInput = .range(col & .Rows.Count).End(xlUp).row
                
                '~~> Find the next row to write to
               If lRowOutput = 0 Then
                    lRowOutput = 2
               Else
                    lRowOutput = wsOutput.range("A" & wsOutput.Rows.Count).End(xlUp).row + 1
                End If
                
                '~~> copy-paste each category type in column A
                .range(col & "2:" & col & lRowInput).Copy _
                wsOutput.range("A" & lRowOutput)
                
                
                
         End If
      Next i
End With

      
      
End With

I feel like I'm close to the solution. I'd appreciate your help guys, thank you!

Answer 1

This code will produce the required results but uses a different approach.

The first thing it does is read the source data into an array, it then goes through that array and extracts the fruits/categories from every column with a header starting with 'Fruit.

Option Explicit

Sub Fruits_add()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim arrDataIn As Variant
Dim arrDataOut As Variant
Dim idxCol As Long
Dim idxRow As Long
Dim cnt As Long

    '~~>  Sheets settings
    Set wsInput = Sheets("Board")
    Set wsOutput = Sheets("FinalBoard")

    ' assumes data on 'Board' starts in A1
    With wsInput
        arrDataIn = .Range("A1").CurrentRegion.Value
    End With
    
    ReDim arrDataOut(1 To 2, 1 To UBound(arrDataIn, 1) * UBound(arrDataIn, 2))
    
    For idxCol = LBound(arrDataIn, 2) To UBound(arrDataIn, 2)
        If arrDataIn(1, idxCol) Like "Fruits*" Then
            For idxRow = LBound(arrDataIn, 1) + 1 To UBound(arrDataIn, 1)
                cnt = cnt + 1
                arrDataOut(1, cnt) = arrDataIn(idxRow, 1)
                arrDataOut(2, cnt) = arrDataIn(idxRow, idxCol)
            Next idxRow
        End If
    Next idxCol
    
    If cnt > 0 Then
        ReDim Preserve arrDataOut(1 To 2, 1 To cnt)
    End If
    
    With wsOutput
        .Range("A1:B1").Value = Array("Category-pasted", "Fruit-pasted")
        .Range("A2").Resize(cnt, 2) = Application.Transpose(arrDataOut)
    End With
    
End Sub

Answer 2

As I explained in my comments you don't need the second loop if you already found the correct row - get the category column early and reuse it later

You can add this variable declaration at the top first

Dim col As String

Then continue with your code for first loop (deleting second loop

With wsInput
        '~~> Find last column in Row 2
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        '~~> loop through columns
        For i = 1 To lCol

Add this to retrieve categories first

            If .Cells(1, i).Value2 Like "Category*" Then
            '~~> Get column name
               colCat = Split(.Cells(, i).Address, "$")(1)                
            End If

            '~~>  research criterias
            If .Cells(1, i).Value2 Like "Fruit-*" Then
                '~~> Get column name
                col = Split(.Cells(, i).Address, "$")(1)
                
                '~~> Get the last row in that column
                lRowInput = .range(col & .Rows.Count).End(xlUp).row
                
                '~~> Find the next row to write to
               If lRowOutput = 0 Then
                    lRowOutput = 2
               Else
                    lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
                End If
                
                '~~> Copy-paste
                .range(col & "2:" & col & lRowInput).Copy _
                wsOutput.range("B" & lRowOutput)
                

Then add this to paste the categories

            '~~> copy-paste each category type in column A
            .range(colCat & "2:" & colCat & lRowInput).Copy _
            wsOutput.range("A" & lRowOutput)
      
            End If
      Next i
End With