Convert Index and match formula sheet to vba macro

[RAM1972]

Hi All
I made a recorded macro, so if any one can help to put the recorded macro in an elegant vba way some modifcations to be made still to end of last row for both imput sheet column A and B as COLUMN C and D may have data of 1500 to 3500 rows to fill columns A and B of imput sheet.

For Product database same lookup from A,B,C.D to last row. (product database can read up to 30000 rows)
recorded macro has been for short range.as below

Formula not to appear in cells.

As below sample of sheet + formula

and recorded macro

Imput sheet

Coding Reference	Coding Description	Product Code	Product Description
=IFERROR(INDEX('Product Database '!$A:$D,MATCH('Imput Datasheet'!C2,'Product Database '!C:C,0),1),"")	=IFERROR(INDEX('Product Database '!$A:$D,MATCH('Imput Datasheet'!C2,'Product Database '!C:C,0),2),"")	0062531	BAC 30L NOIR

<colgroup><col span="2"><col><col></colgroup><tbody>
</tbody>

Product database

Coding Reference	Coding Description	Product Code	Product Description
83119000	WELDING ELECTRODES	0046371	POUR ASSEMBLAGE TRAVAUX COURANTS (ZINGUERIE, FERBLANTERIE) -

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

Sub INDEXMATCHIFERROETEST()
'
' INDEXMATCHIFERROETEST Macro
'

'
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX('Product Database '!C1:C4,MATCH('Imput Datasheet'!RC[2],'Product Database '!C[2],0),1),"""")"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:B2"), Type:=xlFillDefault ***(this need to modify to last row of data)***
Range("A2:B2").Select
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX('Product Database '!C1:C4,MATCH('Imput Datasheet'!RC[1],'Product Database '!C[2],0),2),"""")"
Range("A2:B2").Select
Selection.AutoFill Destination:=Range("A2:B32")
Range("A2:B32").Select
Columns("A:A").ColumnWidth = 19.29
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX('Product Database '!C1:C4,MATCH('Imput Datasheet'!RC[1],'Product Database '!C[1],0),2),"""")"
Range("A2:B2").Select
Selection.AutoFill Destination:=Range("A2:B32")
Range("A2:B32").Select
Columns("B:B").EntireColumn.AutoFit
Selection.AutoFill Destination:=Range("A2:B35"), Type:=xlFillDefault***(this need to modify to last row of data)***
Range("A2:B35").Select
End Sub

 

[JackDanIce]

Try:

Sub M1()

    Dim x       As Long
    Dim arr()   As Variant
    Dim temp    As Variant
    Dim ws1     As Worksheet
    Dim ws2     As Worksheet
    Dim dic     As Object
    
    Const delim As String = "|"
    
    Set ws1 = Sheets("Imput Datasheet")
    Set ws2 = Sheets("Product DataBase ")
    Set dic = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False
    
    With ws2
        For x = 1 To .Cells(.rows.count, 3).End(xlUp).row
            dic(.Cells(x, 3).value) = .Cells(x, 1).value & delim & .Cells(x, 2).value & delim & .Cells(x, 4).value
        Next x
    End With
    
    With ws1
        x = .Cells(.rows.count, 3).End(xlUp).row
        arr = .Cells(2, 1).Resize(x - 1, 4).value
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            If dic.exists(.Cells(x + 1, 3).value) Then
                temp = Split(dic(.Cells(x + 1, 3).value), delim)
                arr(x, 1) = temp(0)
                arr(x, 2) = temp(1)
                arr(x, 4) = temp(2)
                Erase temp
            Else
                arr(x, 1) = Empty
                arr(x, 2) = Empty
                arr(x, 4) = Empty
            End If
        Next x
        
        .Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)).value = arr
    End With
    
    Application.ScreenUpdating = True
    
    Set dic = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Erase arr
    
End Sub

 

[RAM1972]

Hi
Try the code, it works,but the oops,is where there is no matching record of column A and B , it remains blank this ok , but the code also removes the data in column D also. there is only data in column C.

It should be Column A and B blank and Column C and D should appeared.

Actually it updates but removes data in column D also when there is no match.

Actually with code

thanks if you could adjust

Coding Reference	Coding Description	Product Code	Product Description
		62531
		62531
83119000	WELDING ELECTRODES	46371	POUR ASSEMBLAGE TRAVAUX COURANTS (ZINGUERIE, FERBLANTERIE) -
		46373
		3852
		46380

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

With formula

Coding Reference	Coding Description	Product Code	Product Description
		0062531	BAC 30L NOIR
		0062531	BAC 30L NOIR
83119000	WELDING ELECTRODES	0046371	POUR ASSEMBLAGE TRAVAUX COURANTS (ZINGUERIE, FERBLANTERIE) -
		0046373	POUR ASSEMBLAGE RADIO-ELECTRICITE - 50% D’ETAIN - AME DECAPA
		0003852	PANNE POUR FER A SOUDER EXPRESS 159
		0046380	FER A SOUDER GALAXY 25 W

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

 

[JackDanIce]

Try:

Sub M1()


    Dim x       As Long
    Dim arr()   As Variant
    Dim temp    As Variant
    Dim ws1     As Worksheet
    Dim ws2     As Worksheet
    Dim dic     As Object
    
    Const delim As String = "|"
    
    Set ws1 = Sheets("Imput Datasheet")
    Set ws2 = Sheets("Product DataBase ")
    Set dic = CreateObject("Scripting.Dictionary")


    Application.ScreenUpdating = False
    
    With ws2
        For x = 1 To .Cells(.Rows.Count, 3).End(xlUp).Row
            dic(.Cells(x, 3).Value) = .Cells(x, 1).Value & delim & .Cells(x, 2).Value
        Next x
    End With
    
    With ws1
        x = .Cells(.Rows.Count, 3).End(xlUp).Row
        arr = .Cells(2, 1).Resize(x - 1, 4).Text
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            If dic.exists(.Cells(x + 1, 3).Text) Then
                temp = Split(dic(.Cells(x + 1, 3).Text), delim)
                arr(x, 1) = temp(0)
                arr(x, 2) = temp(1)
                Erase temp
            Else
                arr(x, 1) = Empty
                arr(x, 2) = Empty
            End If
        Next x
        
        .Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Text = arr
    End With
    
    Application.ScreenUpdating = True
    
    Set dic = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Erase arr
    
End Sub

 

[RAM1972]

Oops getting

running error mismatch 13

arr = .Cells(2, 1).Resize(x - 1, 4).Text with this line yellow.

Need to adjust thanks

 

[JackDanIce]

Not at a PC right now, try changing .Text to .Value2

If that doesn't work, I suspect a change is needed to read the data as string values as they appear.

 

[RAM1972]

Hi Jack

Tried as per your instruction

Ooops get a runtime error 1004.

Unable to set text property of range class

.Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Text = arr (line in yellow).

 

[JackDanIce]

Change .Text there to .Value2 or try .Value

 

[RAM1972]

It worked both on value2 and Value. but when I delete data in columns A and B and click run for testing nothing happens.

I closed all file and open a fresh file add additional data to it load code in vb , it updated column A and B , but again when I delete column A and B , click run , nothing happens.

So I have to open file each time and run macro manually then it works but reclick again nothing happens .

Is this normal or some adjustements need to be done.

Sub M1()


Dim x As Long
Dim arr() As Variant
Dim temp As Variant
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim dic As Object

Const delim As String = "|"

Set ws1 = Sheets("Imput Datasheet")
Set ws2 = Sheets("Product DataBase ")
Set dic = CreateObject("Scripting.Dictionary")


Application.ScreenUpdating = False

With ws2
For x = 1 To .Cells(.Rows.Count, 3).End(xlUp).Row
dic(.Cells(x, 3).Value) = .Cells(x, 1).Value & delim & .Cells(x, 2).Value
Next x
End With

With ws1
x = .Cells(.Rows.Count, 3).End(xlUp).Row
arr = .Cells(2, 1).Resize(x - 1, 4).Value2

For x = LBound(arr, 1) To UBound(arr, 1)
If dic.exists(.Cells(x + 1, 3).Text) Then
temp = Split(dic(.Cells(x + 1, 3).Text), delim)
arr(x, 1) = temp(0)
arr(x, 2) = temp(1)
Erase temp
Else
arr(x, 1) = Empty
arr(x, 2) = Empty
End If
Next x

.Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr
End With

Application.ScreenUpdating = True

Set dic = Nothing
Set ws1 = Nothing
Set ws2 = Nothing
Erase arr

End Sub

 

[JackDanIce]

Without your file, I do not know why it's doing what it's doing, code is just a guess.

It should be based on results of column C of both sheets.