Speed Up Column Formula with VBA

breynolds0431

Active Member
Joined
Feb 15, 2013
Messages
303
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi. I'm trying to fill a specified formula from row B2 till there's no adjacent data in column C. The below is what I have and it works, but it takes some time, which I know is mostly because it's reaching out to another workbook. But, any ideas to speed it up would be greatly appreciated.

VBA Code:
Sub FillFormula ()

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With

With Windows("Open_Inventory.xlsb")

    Sheets("Combined").Range("B2").Select
       
        Set wsh = Worksheets("Combined")

      i = 2

    While wsh.Cells(i, 3) <> ""

       wsh.Cells(i, 2).FormulaR1C1 = _
       "=IFERROR(VLOOKUP(RC[4]&RC[6]&RC[9],[Prev_Open_Inventory.xlsb]Combined!C1:C2,2,FALSE),"""")"

       i = i + 1

   Wend
   
   Range("B:B").copy
   Range("B1").PasteSpecial Paste:=xlPasteValues

Application.DisplayAlerts = False

   Windows("Prev_Open_Inventory.xlsb").Activate
   ActiveWorkbook.Close SaveChanges:=False

Application.DisplayAlerts = True
     
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
End With

End Sub
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
You could comment how many records you have in each book. How long does your process take?

Try this:

VBA Code:
Sub FillFormula()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant, i As Long, j As Long
  
  Set sh1 = Workbooks("Open_Inventory.xlsb").Sheets("Combined")
  Set sh2 = Workbooks("Prev_Open_Inventory.xlsb").Sheets("Combined")
  a = sh1.Range("F2:K" & sh1.Range("C" & Rows.Count).End(xlUp).Row).Value2
  b = sh2.Range("A1:B" & sh2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  ReDim c(1 To UBound(a), 1 To 1)
  
  For i = 1 To UBound(a)
    For j = 1 To UBound(b)
      If a(i, 1) & a(i, 3) & a(i, 6) = b(j, 1) Then
        c(i, 1) = b(j, 2)
        Exit For
      End If
    Next
  Next
  
  sh1.Range("B2").Resize(UBound(c)).Value = c
End Sub
 
Upvote 0
I put the macro to not consider case sensitive.

VBA Code:
Sub FillFormula1()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant, i As Long, j As Long
 
  Set sh1 = Workbooks("Open_Inventory.xlsb").Sheets("Combined")
  Set sh2 = Workbooks("Prev_Open_Inventory.xlsb").Sheets("Combined")
  a = sh1.Range("F2:K" & sh1.Range("C" & Rows.Count).End(xlUp).Row).Value2
  b = sh2.Range("A1:B" & sh2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  ReDim c(1 To UBound(a), 1 To 1)
 
  For i = 1 To UBound(a)
    For j = 1 To UBound(b)
      If UCase(a(i, 1) & a(i, 3) & a(i, 6)) = UCase(b(j, 1)) Then
        c(i, 1) = b(j, 2)
        Exit For
      End If
    Next
  Next
 
  sh1.Range("B2").Resize(UBound(c)).Value = c
End Sub

_________________________________________________________________________________
I put another macro so you can check which one is faster for you.

VBA Code:
Sub FillFormula()
  Dim sh1 As Worksheet, sh2 As Worksheet, dic As Object
  Dim a As Variant, b As Variant, i As Long
 
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  Set sh1 = Workbooks("Open_Inventory.xlsb").Sheets("Combined")
  Set sh2 = Workbooks("Prev_Open_Inventory.xlsb").Sheets("Combined")
  a = sh1.Range("F2:K" & sh1.Range("C" & Rows.Count).End(xlUp).Row).Value2
  b = sh2.Range("A1:B" & sh2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  ReDim c(1 To UBound(a), 1 To 1)
 
  For i = 1 To UBound(b)
    dic(b(i, 1)) = b(i, 2)
  Next
  For i = 1 To UBound(a)
    If dic.exists(a(i, 1) & a(i, 3) & a(i, 6)) Then c(i, 1) = dic(a(i, 1) & a(i, 3) & a(i, 6))
  Next
 
  sh1.Range("B2").Resize(UBound(c)).Value = c
End Sub
 
Upvote 0
That last one is a clear winner! Thank you very much! I'm not even going to act like I understand how that works. Could I give you another similar formula fill macro to apply that last macro to?

VBA Code:
Sub copy()
    
    Set wsh = Worksheets("Combined")

    i = 2
 
    While wsh.Cells(i, 2) <> ""

        wsh.Cells(i, 51).FormulaR1C1 = _
        "=IFERROR(VLOOKUP(RC[-46]&RC[-44]&RC[-41],[log updated.xlsb]log'!C1:C17,17,FALSE),""Unknwn"")"

        i = i + 1
 
    Wend
    
    Range("AY:AY").copy
    Range("AY1").PasteSpecial Paste:=xlPasteValues

Range("A2").Select
End Sub
 
Upvote 0
I tried to apply your code to my copy macro, but it keeps getting hung up on the set sh2. I think it's due to that workbook needing to be open. I was hoping to avoid that and not have it open to apply the formula.
 
Upvote 0
It is best to open the book, make the formula and close the book.
 
Upvote 0
Could I give you another similar formula fill macro to apply that last macro to?

Try this

VBA Code:
Sub copy()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, a As Variant, b As Variant
  Dim dic As Object
  
  Set sh1 = ThisWorkbook.Sheets("Combined")
  Set sh2 = Workbooks("log updated.xlsb").Sheets("log")
  
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  'Stores in the array "a" columns E to J and from row 2 to the last row with data from column B
  a = sh1.Range("E2:J" & sh1.Range("B" & Rows.Count).End(xlUp).Row).Value2
  'Stores in the array "b" columns A to Q and from row 2 to the last row with data from column A
  b = sh2.Range("A2:Q" & sh2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  ReDim c(1 To UBound(a), 1 To 1)
  
  'for each data in array "b"
  For i = 1 To UBound(b)
    'Stores unique values of column A(1) and its respective data of column Q(17)
    dic(b(i, 1)) = b(i, 17)
  Next
  
  'for each data in array "a"
  For i = 1 To UBound(a)
    'Compare the chain E & G & J, In the array they were stored as columns 1, 3 and 6
    If dic.exists(a(i, 1) & a(i, 3) & a(i, 6)) Then
      'If the string exists, then in the array "c" it stores the value of Q
      c(i, 1) = dic(a(i, 1) & a(i, 3) & a(i, 6))
    End If
  Next
  'All searches and results are processed in memory, until the end the result puts it on the sheet:
  sh1.Range("AY2").Resize(UBound(c)).Value = c
End Sub
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,213
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top