copy/paste range of cells x times based on condition - excel

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