# Problem executing code VBA



## sofas (Saturday at 11:35 AM)

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 (Saturday at 12:00 PM)

Can you show a short screen display of your  data.


----------



## sofas (Saturday at 12:11 PM)

PCL said:


> Can you show a short screen display of your  data.


----------



## sofas (Saturday at 1:11 PM)

*To clarify more*



```
Sub TEST_MH2()
Dim MT As Worksheet
Dim lr As Long
Set MT = Worksheets("sheet4")

Application.ScreenUpdating = False
lr = MT.Range("A" & Rows.Count).End(xlUp).Row
MT.Range("F2:i" & lr).ClearContents

  With MT.Range("F2:F" & lr)
       .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,1,0)"
       .Value = .Value
           With MT.Range("G2:G" & lr)
            .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,2,0)"
            .Value = .Value
               With MT.Range("H2:H" & lr)
               .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,3,0)"
               .Value = .Value
                   With MT.Range("I2:I" & lr)
                  .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,4,0)"
                  .Value = .Value
  End With
   End With
    End With
     End With
  Application.ScreenUpdating = True
End Sub
```


----------



## PCL (Saturday at 1:23 PM)

Is  it  faster ???

```
Option Explicit

Sub Test2()
Dim a, b
Dim I As Long, II As Long, LR As Long
Dim j As Integer
Dim ObjDic   As Object
Set ObjDic = CreateObject("Scripting.Dictionary")
Dim K, T
    LR = Cells(Rows.Count, "A").End(3).Row
    a = Range("A2:D" & LR)
    For I = LBound(a, 1) To UBound(a, 1)
        ObjDic(a(I, 1)) = a(I, 2) & "/" & a(I, 3) & "/" & a(I, 4)
    Next I
    AAA = ObjDic.keys: BBB = ObjDic.items
    LR = Cells(Rows.Count, "E").End(3).Row
    b = Range("E2:E" & LR)
    ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 4)
    
    For I = LBound(b, 1) To UBound(b, 1)
        For Each K In ObjDic.keys
            If K Like "*" & b(I, 1) & "*" Then
                T = Split(ObjDic(K), "/")
                For II = 0 To UBound(T, 1)
                    b(I, 2 + II) = T(II)
                Next II
                Exit For
            End If
        Next K
    Next I
    Cells(2, "E").Resize(UBound(b, 1), 4) = b
    

End Sub
```


----------



## PCL (Saturday at 1:32 PM)

Oups an update

```
Option Explicit

Sub Test2()
Dim a, b
Dim I As Long, II As Long, LR As Long
Dim j As Integer
Dim ObjDic   As Object
Set ObjDic = CreateObject("Scripting.Dictionary")
Dim K, T
    LR = Cells(Rows.Count, "A").End(3).Row
    a = Range("A2:D" & LR)
    For I = LBound(a, 1) To UBound(a, 1)
        ObjDic(a(I, 1)) = a(I, 2) & "/" & a(I, 3) & "/" & a(I, 4)
    Next I
    LR = Cells(Rows.Count, "E").End(3).Row
    b = Range("E2:E" & LR)
    ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 4)
    
    For I = LBound(b, 1) To UBound(b, 1)
        For Each K In ObjDic.keys
            If K Like "*" & b(I, 1) & "*" Then
                T = Split(ObjDic(K), "/")
                 b(I, 1) = K
                For II = 0 To UBound(T, 1)
                    b(I, 2 + II) = T(II)
                Next II
                Exit For
            End If
        Next K
    Next I
    Cells(2, "F").Resize(UBound(b, 1), 4) = b
    

End Sub
```


----------



## sofas (Saturday at 1:34 PM)

PCL said:


> Is  it  faster ???
> 
> ```
> Option Explicit
> ...











						cvs
					

MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.



					www.mediafire.com
				



Please have a look at the file, please, there is an error


----------



## johnnyL (Saturday at 2:05 PM)

How many rows of data are you dealing with & you said it was slow, how long does it take to complete?


----------



## sofas (Saturday at 2:06 PM)

johnnyL said:


> How many rows of data are you dealing with & you said it was slow, how long does it take to complete?


Hello, first of all, thank you for your interest in the subject. The rows exceed 6000 rows
A suggestion  
PCL​that works faster when experimenting, but when adding the original data, it gives me an error, I don't know why


----------



## johnnyL (Saturday at 2:15 PM)

How much time to complete your code?


----------



## sofas (Saturday at 11:35 AM)

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 (Saturday at 2:19 PM)

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 (Saturday at 2:20 PM)

more than 30 seconds


johnnyL said:


> How much time to complete your code?


----------



## sofas (Saturday at 2:26 PM)

PCL said:


> There is next update to do
> 
> ```
> ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 4)
> ...


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 (Saturday at 2:27 PM)

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 (Saturday at 2:28 PM)

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


----------



## sofas (Saturday at 2:36 PM)

PCL said:


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


----------



## sofas (Saturday at 2:56 PM)

sofas said:


> View attachment 82275


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


----------



## johnnyL (Saturday at 3:18 PM)

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 (Saturday at 4:17 PM)

johnnyL said:


> Try the following code:
> 
> 
> ```
> ...



Thank you nice and fast


----------



## johnnyL (Saturday at 4:26 PM)

Completed 6000 rows in 0.15625 seconds? WOW!


----------



## sofas (Saturday at 11:35 AM)

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 (Sunday at 4:24 AM)

Sofas, can you please confirm time measurements done and can you do same measurements with others codes: Yours and mine
The idea is just to understand with method the best :
   So far ( for me ) using formulas was the slowest manner


----------



## sofas (Sunday at 5:59 AM)

No, the implementation was only on a trial version with about 100 rows. I will try all the suggested methods on the original file to see which one is better.  Thank you all for the help


----------



## PCL (Sunday at 6:05 AM)

*I will try all the suggested methods on the original file to see which one is better*
Super, and thanks to let's know the score ... just for information.


----------

