Problem executing code VBA

[sofas]

Hello, how can I fix this code or shorten it? It works fine, but it's slow

Sub TEST()

Dim MT As Worksheet
Set MT = Feuil1
  With MT.Range("F2:F" & MT.Range("a" & Rows.Count).End(3).Row)
      .Formula = "=VLOOKUP(""*""&RC[-1]&""*"",C1:C4,1,0)"
    .Value = .Value
    With MT.Range("G2:G" & MT.Range("a" & Rows.Count).End(3).Row)
     .Formula = "=VLOOKUP(""*""&RC[-2]&""*"",C1:C4,2,0)"
    .Value = .Value
      With MT.Range("H2:H" & MT.Range("a" & Rows.Count).End(3).Row)
      .Formula = "=VLOOKUP(""*""&RC[-3]&""*"",C1:C4,3,0)"
    .Value = .Value
    With MT.Range("I2:I" & MT.Range("a" & Rows.Count).End(3).Row)
      .Formula = "=VLOOKUP(""*""&RC[-4]&""*"",C1:C4,4,0)"
   .Value = .Value
  End With
  End With
  End With
  End With
End Sub

 

[PCL]

There is next update to do

    ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 4)

change to

    ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 5)

 

[sofas]

more than 30 seconds

How much time to complete your code?

 

[sofas]

There is next update to do

    ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 4)

change to

    ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 5)

Thank you very much, the code has been implemented with a huge difference.
you are genius
Only note when there are two values in column b ABC_DEF Example DEF is copied colmun 4

 

[PCL]

Can you manage to turn off calculation:
Formula > Calculation Option > Manual
Run the macro
Turn back calculation to Automatic
and see if it is faster

 

[PCL]

Good, so you don't need to do the last test.
Enjoy Excel

 

[sofas]

Good, so you don't need to do the last test.
Enjoy Excel

 

[sofas]

View attachment 82275

Thank you, the problem has been solved by replacing the / sign with another symbol

 

[johnnyL]

Try the following code:

Sub TEST_MH2()
'
    Dim StartTime               As Double
    StartTime = Timer
'
    Dim lr                      As Long
    Dim TableRange              As Range
    Dim FormulasArray(1 To 4)   As Variant, HeaderArray     As Variant
    Dim MT                      As Worksheet
'
    Set MT = Worksheets("sheet4")
'
    Application.ScreenUpdating = False                                                      ' Turn ScreenUpdating off
'
    lr = MT.Range("A" & Rows.Count).End(xlUp).Row                                           ' Get last used row of column A
'
    HeaderArray = MT.Range("F1:I1")                                                         ' Save the header row for columns F:I
'
    Columns("F:I").Delete                                                                   ' Delete the columns of data
'
    Columns("F").Resize(, 4).EntireColumn.Insert                                            ' Insert the blank columns
'
    MT.Range("F1:I1") = HeaderArray                                                         ' Write the header back to the columns
'
'
    MT.ListObjects.Add(xlSrcRange, MT.Range("$F$1:$I$" & lr), , xlYes).Name = "Table1"      ' Convert the F:I range to a table
'
    FormulasArray(1) = "=VLOOKUP(""*""&E2&""*"",A:D,1,0)"                                   ' Column F formula
    FormulasArray(2) = "=VLOOKUP(""*""&E2&""*"",A:D,2,0)"                                   ' Column G formula
    FormulasArray(3) = "=VLOOKUP(""*""&E2&""*"",A:D,3,0)"                                   ' Column H formula
    FormulasArray(4) = "=VLOOKUP(""*""&E2&""*"",A:D,4,0)"                                   ' Column I formula
'
    MT.Range("F2:I2").Formula = FormulasArray                                               ' Write FormulasArray to sheet
'
    With MT.ListObjects("Table1")
        Set TableRange = .Range                                                             '   Save the range of 'Table1'
        .Unlist                                                                             '   Convert the table back to a range
    End With
'
    With TableRange
        .Interior.ColorIndex = xlColorIndexNone                                             '   Remove the .Interior.ColorIndex that the adding table did
        .Font.ColorIndex = xlColorIndexAutomatic                                            '   Remove the .Font.ColorIndex that the adding table did
        .Borders.LineStyle = xlLineStyleNone                                                '   Remove the .Borders.LineStyle that the adding table did
    End With
'
'
    With MT.Range("F2:I" & lr)
        .Value = .Value                                                                     '   Remove the formulas leaving just the values
    End With
'
    Application.ScreenUpdating = True                                                       ' Turn ScreenUpdating back on
'
    MsgBox "Script completed in " & Timer - StartTime & " seconds."                         ' Let user know that script has completed
End Sub

 

[sofas]

Try the following code:

Sub TEST_MH2()
'
    Dim StartTime               As Double
    StartTime = Timer
'
    Dim lr                      As Long
    Dim TableRange              As Range
    Dim FormulasArray(1 To 4)   As Variant, HeaderArray     As Variant
    Dim MT                      As Worksheet
'
    Set MT = Worksheets("sheet4")
'
    Application.ScreenUpdating = False                                                      ' Turn ScreenUpdating off
'
    lr = MT.Range("A" & Rows.Count).End(xlUp).Row                                           ' Get last used row of column A
'
    HeaderArray = MT.Range("F1:I1")                                                         ' Save the header row for columns F:I
'
    Columns("F:I").Delete                                                                   ' Delete the columns of data
'
    Columns("F").Resize(, 4).EntireColumn.Insert                                            ' Insert the blank columns
'
    MT.Range("F1:I1") = HeaderArray                                                         ' Write the header back to the columns
'
'
    MT.ListObjects.Add(xlSrcRange, MT.Range("$F$1:$I$" & lr), , xlYes).Name = "Table1"      ' Convert the F:I range to a table
'
    FormulasArray(1) = "=VLOOKUP(""*""&E2&""*"",A:D,1,0)"                                   ' Column F formula
    FormulasArray(2) = "=VLOOKUP(""*""&E2&""*"",A:D,2,0)"                                   ' Column G formula
    FormulasArray(3) = "=VLOOKUP(""*""&E2&""*"",A:D,3,0)"                                   ' Column H formula
    FormulasArray(4) = "=VLOOKUP(""*""&E2&""*"",A:D,4,0)"                                   ' Column I formula
'
    MT.Range("F2:I2").Formula = FormulasArray                                               ' Write FormulasArray to sheet
'
    With MT.ListObjects("Table1")
        Set TableRange = .Range                                                             '   Save the range of 'Table1'
        .Unlist                                                                             '   Convert the table back to a range
    End With
'
    With TableRange
        .Interior.ColorIndex = xlColorIndexNone                                             '   Remove the .Interior.ColorIndex that the adding table did
        .Font.ColorIndex = xlColorIndexAutomatic                                            '   Remove the .Font.ColorIndex that the adding table did
        .Borders.LineStyle = xlLineStyleNone                                                '   Remove the .Borders.LineStyle that the adding table did
    End With
'
'
    With MT.Range("F2:I" & lr)
        .Value = .Value                                                                     '   Remove the formulas leaving just the values
    End With
'
    Application.ScreenUpdating = True                                                       ' Turn ScreenUpdating back on
'
    MsgBox "Script completed in " & Timer - StartTime & " seconds."                         ' Let user know that script has completed
End Sub

Thank you nice and fast

 

[johnnyL]

Completed 6000 rows in 0.15625 seconds? WOW!