Paste values as many time as there are filled rows bellow - excel

Question

I've been trying to find a solution to the following problem for a week but couldn't find anything...
Here is the point ; I've got three different worksheets in my workbook;
worksheets("Board")
worksheets("reference")
worksheets("FinalBoard")
In worksheets("Board") there are multiple column filled with datas with differents headers. I could do a code that paste each datas bellow in sheets("FinalBoard") one bellow the other only if those headers begin by the value "Fruit".
=>worksheets("Board")
A
B
C
D
Fruit-1
Fruit-2
Fruit-3
Vege-1
x
x
x
Y
x
x
x
Y
here is my code;
Sub test()
Worksheets("FinalBoard").Activate
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 Col As String
'~~> Setting sheets
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(2, .columns.Count).End(xlToLeft).column
'~~> Loop through columns
For i = 1 To lCol
'~~> Check for my criterias
If .Cells(2, 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 all datas bellow each headers
.Range(Col & "3:" & Col & lRowInput).Copy _
wsOutput.Range("B" & lRowOutput)
End If
Next i
End With
End Sub
However, the problem is here I'd like to add an extra condition. During this process, if each of these headers match with a cell contained in a list of words in worksheets("reference") then copy the value beside that cell(located in column "B") and paste it in worksheets("Final Board") in column("A").
=>worksheets("reference") ;
A
B
Fruit-1
N01
Fruit-2
N02
Fruit-3
N03
Fruit-4
N04
worksheets("FinalBoard") ;
| A | B |
| -------- | -------------- |
| Code | X VALUES |
| N01 | x |
| N02 | x|
|N03|x|
As soon as I run my code, nothing happens; no message, no error.
I'd also like to insert the following code in the previous I showed you to ease the process and not run this macro again!
Here is it:
Dim wsTEST1, wsTEST2, wsTEST3 As Worksheet
Dim lCol As Long
Dim i, j, e As Long
Dim Col As String
Dim cell As Range
Dim lastlineRef, lastlineDistrib, lastlineResult As Long
'~~> Declaration
Set wsTEST1 = Sheets("Board")
Set wsTEST2 = Sheets("Reference")
Set wsTEST3 = Sheets("FinalBoard")
With wsTEST1
'~~> loop through columns ( declaration)
lCol = .Cells(2, .columns.Count).End(xlToLeft).column
lastlineRef = Worksheets("Reference").Range("A" & rows.Count).End(xlUp).row
lastlineResult = Worksheets("FinalBoard").Range("A" & rows.Count).End(xlUp).row
'~~> loop through columns
For i = 1 To lCol 'unti last column
'~~> research criterias
If .Cells(2, i).Value Like "Fruit*" Then
For e = 1 To lastlineResult
If wsTEST1.Cells(2, i).Value = Worksheets("Reference").Range("A" & i) Then
Worksheets("Reference").Range("A" & e).Offset(, 1).Copy Worksheets("FinalBoard").Range("A" & e)
End If
Next e
End If
Next i
End With
end sub
I feel like I'm so close to find the correct code... I'd heavily appreciate your help once again ! :)

Answer 1

You could use a Dictionary Object for the lookup.
Sub test()
Dim wsInput As Worksheet, wsOutput As Worksheet, wsRef As Worksheet
Dim lRowInput As Long, lRowOutput As Long, iLastRef As Long
Dim lCol As Long, i As Long, n As Long, s As String
' dictionary as look up table
Dim dict As Object, key As String
Set dict = CreateObject("Scripting.Dictionary")
Set wsRef = Sheets("reference")
With wsRef
iLastRef = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRef
key = Trim(.Cells(i, "A"))
dict(key) = .Cells(i, "B")
Next
End With
'~~> Setting sheets
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
lRowOutput = 2
With wsInput
' Find last column in Row 2
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
' Loop through columns
For i = 1 To lCol
'~~> Check for my criterias
s = Trim(.Cells(2, i).Value2)
If s Like "Fruit*" Then
' Get the last row in that column
lRowInput = .Cells(.Rows.Count, i).End(xlUp).Row
n = lRowInput - 2 ' no of rows to copy
' Copy all datas bellow each headers
.Cells(3, i).Resize(n).Copy wsOutput.Range("B" & lRowOutput)
' add col A if match
If dict.exists(s) Then
wsOutput.Range("A" & lRowOutput).Resize(n) = dict(s)
End If
lRowOutput = lRowOutput + n
End If
Next i
End With
End Sub