CODEWITHSUNDEEP
excelvbaif-statementforeach
Mido88
Mido88

Reputation: 29

copy/paste range of cells x times based on condition

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!

Upvotes: 0

Views: 218

Answers (2)

norie
norie

Reputation: 9867

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

Upvotes: 2

dbmitch
dbmitch

Reputation: 5386

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

Upvotes: 1

Related Questions