Looking For Tips To Improve My VBA

W

who am i

New Member
Joined
Oct 28, 2024
Messages
8
Office Version
  1. 2019
I am very new to VBA and though below works, I bet it can be written more concisely. Thank you so much!

VBA Code: 
Sub trial_v2()
  Dim Sales_Rep As Integer
  Dim IMR As Integer
  Dim DOWN_PAYMENT As Integer
  Dim Tax_Adj As Integer
  Dim Material As Integer
  Dim Service_Item As Integer
  Dim Last_Row As Long
  Dim i As Long
 
 
    Application.ScreenUpdating = False
 
  With Sheets("Sheet1")
  
    Last_Row = Range("a" & Rows.Count).End(xlUp).Row
  
  
    Sales_Rep = .Rows(1).Find(What:="Sales Representative Name", LookAt:=xlWhole, MatchCase:=False).Column
    .Columns(Sales_Rep + 1).Insert
     .Range(.Cells(2, Sales_Rep + 1), .Cells(Last_Row, Sales_Rep + 1)).Formula2R1C1 = "=VLOOKUP(RC[-1],'[Book1.xlsm]IMR Table'!C1:C2,2,FALSE)"
 
   .Cells(1, Sales_Rep + 1).FormulaR1C1 = "IMR"
    IMR = Sales_Rep + 1
  
  
    .Columns(IMR).Copy
    .Columns(IMR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  
    .Columns(Sales_Rep).Delete
  
  
    Last_Row = Range("a" & Rows.Count).End(xlUp).Row
  
  
  
  
    .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 3).Formula = "Down Payment?"
    DOWN_PAYMENT = .Rows(1).Find(What:="Down Payment?", LookAt:=xlWhole, MatchCase:=False).Column
    .Range(.Cells(2, DOWN_PAYMENT), .Cells(Last_Row, DOWN_PAYMENT)).Formula2R1C1 = _
    "=or(isnumber(search(""Down Pay"",INDEX(C[" & 1 + (0 - DOWN_PAYMENT) & "]:C,row(RC),match(""Material"",(R1),0)))),isnumber(search(""Down Pay"",INDEX(C[" & 1 + (0 - DOWN_PAYMENT) & "]:C,row(RC),match(""Billing Type Description"",(R1),0)))),isnumber(search(""Down Pay"",INDEX(C[" & 1 + (0 - DOWN_PAYMENT) & "]:C,row(RC),match(""Material Description"",(R1),0)))))"
 
  For i = Last_Row To 2 Step -1
  If Cells(i, DOWN_PAYMENT).Value = True Then
            Rows(i).EntireRow.Delete
        End If
           
          Next i
        
        
.Columns(DOWN_PAYMENT).Delete


Last_Row = Range("a" & Rows.Count).End(xlUp).Row
 
    .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 3).Formula = "Tax Adj?"
    Tax_Adj = .Rows(1).Find(What:="Tax Adj?", LookAt:=xlWhole, MatchCase:=False).Column
    .Range(.Cells(2, Tax_Adj), .Cells(Last_Row, Tax_Adj)).Formula2R1C1 = _
    "=or(isnumber(search(""TAXADJ"",INDEX(C[" & 1 + (0 - Tax_Adj) & "]:C,row(RC),match(""Material"",(R1),0)))),isnumber(search(""Tax Adj"",INDEX(C[" & 1 + (0 - Tax_Adj) & "]:C,row(RC),match(""Material Description"",(R1),0)))))"
 
  For i = Last_Row To 2 Step -1
  If Cells(i, Tax_Adj).Value = True Then
            Rows(i).EntireRow.Delete
        End If
           
          Next i
 
 
    
.Columns(Tax_Adj).Delete


Last_Row = Range("a" & Rows.Count).End(xlUp).Row


.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 3).Formula = "Service Item?"
    Service_Item = .Rows(1).Find(What:="Service Item?", LookAt:=xlWhole, MatchCase:=False).Column
    Material = .Rows(1).Find(What:="Material", LookAt:=xlWhole, MatchCase:=False).Column
    .Range(.Cells(2, Service_Item), .Cells(Last_Row, Service_Item)).Formula2R1C1 = _
    "=ISNUMBER(MATCH(RC[" & (Material - Service_Item) & "],'[Book1.xlsm]IMR Table'!C9,0))"
 
  For i = Last_Row To 2 Step -1
  If Cells(i, Service_Item).Value = True Then
            Rows(i).EntireRow.Delete
        End If
           
          Next i
 
 
    
.Columns(Service_Item).Delete


Last_Row = Range("a" & Rows.Count).End(xlUp).Row

.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 3).Formula = "Blank Project ID?"
    Blank_Project_ID = .Rows(1).Find(What:="Blank Project ID?", LookAt:=xlWhole, MatchCase:=False).Column
    Project_ID = .Rows(1).Find(What:="Project ID", LookAt:=xlWhole, MatchCase:=False).Column
    .Range(.Cells(2, Blank_Project_ID), .Cells(Last_Row, Blank_Project_ID)).Formula2R1C1 = _
    "=AND(VALUE(RC1)>0,LEN(RC[" & (Project_ID - Blank_Project_ID) & "])<2)"





  
  
  
     Application.ScreenUpdating = True
   
   
      End With
   
         Cells(1, 1).Select
  
End Sub
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Not sure what sort of improvements you're looking for. IMO, you have only two variable types declared yet have eight lines, so room for condensing there. Then there seems to be a few unnecessary double spaced (or more ?) lines and the indentation is not what I would call "correct". However, none of that will affect the way it runs - it's just not as easy to follow and as concise as it could be. Is it as efficient as it could be? Don't know as I tend to gloss over code that is written/indented like that if I'm not looking for a run-time type of problem in need of a solution.
 
Upvote 0
Currently your code has 3 sections that are deleted row by row.
I replaced those sections to delete all the rows with a single instruction.

Replace your code with the following:

VBA Code: 
Sub trial_v3()
  Dim sh As Worksheet
  Dim Last_Row As Long, i As Long, n As Long, col As Long
  Dim arT As Variant
  Dim f As Range, f2 As Range, rng As Range
  Dim IMR As Integer, Sales_Rep As Integer, Blank_Project_ID As Integer, Project_ID As Integer
 
  Application.ScreenUpdating = False
 
  Set sh = Sheets("Sheet1")
 
  Last_Row = sh.Range("A" & Rows.Count).End(xlUp).Row
  Sales_Rep = sh.Rows(1).Find(What:="Sales Representative Name", LookAt:=xlWhole, MatchCase:=False).Column
  sh.Columns(Sales_Rep + 1).Insert
  sh.Range(sh.Cells(2, Sales_Rep + 1), sh.Cells(Last_Row, Sales_Rep + 1)).FormulaR1C1 = _
    "=VLOOKUP(RC[-1],'[Book1.xlsm]IMR Table'!C1:C2,2,FALSE)"
  sh.Cells(1, Sales_Rep + 1).FormulaR1C1 = "IMR"
  IMR = Sales_Rep + 1
  sh.Columns(IMR).Copy
  sh.Columns(IMR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  sh.Columns(Sales_Rep).Delete
  
  'DELETE ROWS
  Set rng = Range("A" & Last_Row + 1)
  arT = Array("Material", "Material Description", "Billing Type Description")
 
  For n = 0 To UBound(arT)
    Set f = sh.Range("1:1").Find(arT(n), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      col = f.Column
    
      For i = 2 To Last_Row
      
        If n = 0 Then     'material
          If InStr(1, sh.Cells(i, f.Column).Value, "Down Pay", vbTextCompare) > 0 Or _
             InStr(1, sh.Cells(i, f.Column).Value, "TAXADJ", vbTextCompare) > 0 Then
             Set rng = Union(rng, sh.Range("A" & i))
          End If
        
          '"=ISNUMBER(MATCH(RC[" & (Material - Service_Item) & "],'[Book1.xlsm]IMR Table'!C9,0))"
          If sh.Range("C" & i).Value <> "" Then
            Set f2 = Workbooks("Book1").Sheets("IMR Table").Range("I:I").Find( _
              sh.Range("C" & i).Value, , xlValues, xlWhole, , , False)
            If Not f2 Is Nothing Then Set rng = Union(rng, sh.Range("A" & i))
          End If
        End If
      
        If n = 1 Then      'Material Description
          If InStr(1, sh.Cells(i, f.Column).Value, "Down Pay", vbTextCompare) > 0 Or _
             InStr(1, sh.Cells(i, f.Column).Value, "Tax Adj", vbTextCompare) > 0 Then
             Set rng = Union(rng, sh.Range("A" & i))
          End If
        End If
       
        If n = 2 Then     'Billing Type Description
          If InStr(1, sh.Cells(i, f.Column).Value, "Down Pay", vbTextCompare) > 0 Then
             Set rng = Union(rng, sh.Range("A" & i))
          End If
        End If
      Next
    End If
  Next
 
  If Not rng Is Nothing Then
    rng.EntireRow.Delete
  End If
  'END DELETE ROWS
  
  Last_Row = sh.Range("a" & Rows.Count).End(xlUp).Row
  sh.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 3).Formula = "Blank Project ID?"
  Blank_Project_ID = sh.Rows(1).Find(What:="Blank Project ID?", LookAt:=xlWhole, MatchCase:=False).Column
  Project_ID = sh.Rows(1).Find(What:="Project ID?", LookAt:=xlWhole, MatchCase:=False).Column
  sh.Range(sh.Cells(2, Blank_Project_ID), sh.Cells(Last_Row, Blank_Project_ID)).FormulaR1C1 = _
    "=AND(VALUE(RC1)>0,LEN(RC[" & (Project_ID - Blank_Project_ID) & "])<2)"
  
  Application.ScreenUpdating = True
End Sub

The size of the macro was probably not reduced, but it will certainly be faster at deleting records.

Try and comment.
😅
 
Upvote 0
Solution
DanteAmor said:
The size of the macro was probably not reduced, but it will certainly be faster at deleting records.
Click to expand...

Now I was able to reduce the row deletion section. I also eliminated a couple of cycles, now the execution should be faster.

VBA Code: 
Sub trial_v4()
  Dim sh As Worksheet
  Dim Last_Row As Long, i As Long, n As Long, col1 As Long, col2 As Long, col3 As Long
  Dim fa As Range, fb As Range, fc As Range, f2 As Range, rng As Range
  Dim IMR As Integer, Sales_Rep As Integer, Blank_Project_ID As Integer, Project_ID As Integer
 
  Application.ScreenUpdating = False
 
  Set sh = Sheets("Sheet1")
 
  Last_Row = sh.Range("A" & Rows.Count).End(xlUp).Row
  Sales_Rep = sh.Rows(1).Find(What:="Sales Representative Name", LookAt:=xlWhole, MatchCase:=False).Column
  sh.Columns(Sales_Rep + 1).Insert
  sh.Range(sh.Cells(2, Sales_Rep + 1), sh.Cells(Last_Row, Sales_Rep + 1)).FormulaR1C1 = _
    "=VLOOKUP(RC[-1],'[Book1.xlsm]IMR Table'!C1:C2,2,FALSE)"
  sh.Cells(1, Sales_Rep + 1).FormulaR1C1 = "IMR"
  IMR = Sales_Rep + 1
  sh.Columns(IMR).Copy
  sh.Columns(IMR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  sh.Columns(Sales_Rep).Delete
  
  'DELETE ROWS
    Set rng = Range("A" & Last_Row + 1)
    arT = Array("Material", "Material Description", "Billing Type Description")
    col1 = sh.Range("1:1").Find("Material", , xlValues, xlWhole, , , False).Column
    col2 = sh.Range("1:1").Find("Material Description", , xlValues, xlWhole, , , False).Column
    col3 = sh.Range("1:1").Find("Billing Type Description", , xlValues, xlWhole, , , False).Column
 
    For i = 2 To Last_Row
      If InStr(1, sh.Cells(i, col1).Value, "Down Pay", vbTextCompare) > 0 Or _
         InStr(1, sh.Cells(i, col1).Value, "TAXADJ", vbTextCompare) > 0 Or _
         InStr(1, sh.Cells(i, col2).Value, "Down Pay", vbTextCompare) > 0 Or _
         InStr(1, sh.Cells(i, col2).Value, "Tax Adj", vbTextCompare) > 0 Or _
         InStr(1, sh.Cells(i, col3).Value, "Down Pay", vbTextCompare) > 0 Then
         Set rng = Union(rng, sh.Range("A" & i))
      End If
    
      '"=ISNUMBER(MATCH(RC[" & (Material - Service_Item) & "],'[Book1.xlsm]IMR Table'!C9,0))"
      If sh.Range("C" & i).Value <> "" Then
        Set f2 = Workbooks("Book1").Sheets("IMR Table").Range("I:I").Find( _
          sh.Range("C" & i).Value, , xlValues, xlWhole, , , False)
        If Not f2 Is Nothing Then Set rng = Union(rng, sh.Range("A" & i))
      End If
    Next
 
    rng.EntireRow.Delete
  'END DELETE ROWS
  
  Last_Row = sh.Range("a" & Rows.Count).End(xlUp).Row
  sh.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 3).Formula = "Blank Project ID?"
  Blank_Project_ID = sh.Rows(1).Find(What:="Blank Project ID?", LookAt:=xlWhole, MatchCase:=False).Column
  Project_ID = sh.Rows(1).Find(What:="Project ID?", LookAt:=xlWhole, MatchCase:=False).Column
  sh.Range(sh.Cells(2, Blank_Project_ID), sh.Cells(Last_Row, Blank_Project_ID)).FormulaR1C1 = _
    "=AND(VALUE(RC1)>0,LEN(RC[" & (Project_ID - Blank_Project_ID) & "])<2)"
  
  Application.ScreenUpdating = True
End Sub

😇
 
Upvote 0
We can also reduce this code:
VBA Code: 
  Last_Row = sh.Range("A" & Rows.Count).End(xlUp).Row
  Sales_Rep = sh.Rows(1).Find(What:="Sales Representative Name", LookAt:=xlWhole, MatchCase:=False).Column
  sh.Columns(Sales_Rep + 1).Insert
  sh.Range(sh.Cells(2, Sales_Rep + 1), sh.Cells(Last_Row, Sales_Rep + 1)).FormulaR1C1 = _
    "=VLOOKUP(RC[-1],'[Book1.xlsm]IMR Table'!C1:C2,2,FALSE)"
  sh.Cells(1, Sales_Rep + 1).FormulaR1C1 = "IMR"
  IMR = Sales_Rep + 1
  sh.Columns(IMR).Copy
  sh.Columns(IMR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  sh.Columns(Sales_Rep).Delete

To this:
VBA Code: 
  Last_Row = sh.Range("A" & Rows.Count).End(xlUp).Row
  Sales_Rep = sh.Rows(1).Find(What:="Sales Representative Name", LookAt:=xlWhole, MatchCase:=False).Column
  With sh.Range(sh.Cells(2, Sales_Rep), sh.Cells(Last_Row, Sales_Rep))
    .Value = Evaluate("=IF({1},VLOOKUP(T(IF({1}," & .Address & ")),'[book1.xlsm]IMR Table'!$A:$B,2,0))")
  End With
  sh.Cells(1, Sales_Rep).Value = "IMR"
The above does not insert and delete the column. It also evaluates and enters the result without having to enter the VLOOKUP formula on the sheet, Which will also make the macro faster.

Complete code:
VBA Code: 
Sub trial_v4()
  Dim sh As Worksheet
  Dim Last_Row As Long, i As Long, n As Long, col1 As Long, col2 As Long, col3 As Long
  Dim fa As Range, fb As Range, fc As Range, f2 As Range, rng As Range
  Dim Sales_Rep As Integer, Blank_Project_ID As Integer, Project_ID As Integer
  
  Application.ScreenUpdating = False
 
  Set sh = Sheets("Sheet1")
 
  Last_Row = sh.Range("A" & Rows.Count).End(xlUp).Row
  Sales_Rep = sh.Rows(1).Find(What:="Sales Representative Name", LookAt:=xlWhole, MatchCase:=False).Column
  With sh.Range(sh.Cells(2, Sales_Rep), sh.Cells(Last_Row, Sales_Rep))
    .Value = Evaluate("=IF({1},VLOOKUP(T(IF({1}," & .Address & ")),'[book1.xlsm]IMR Table'!$A:$B,2,0))")
  End With
  sh.Cells(1, Sales_Rep).Value = "IMR"
  
  'DELETE ROWS
    Set rng = Range("A" & Last_Row + 1)
    col1 = sh.Range("1:1").Find("Material", , xlValues, xlWhole, , , False).Column
    col2 = sh.Range("1:1").Find("Material Description", , xlValues, xlWhole, , , False).Column
    col3 = sh.Range("1:1").Find("Billing Type Description", , xlValues, xlWhole, , , False).Column
 
    For i = 2 To Last_Row
      If InStr(1, sh.Cells(i, col1).Value, "Down Pay", vbTextCompare) > 0 Or _
         InStr(1, sh.Cells(i, col1).Value, "TAXADJ", vbTextCompare) > 0 Or _
         InStr(1, sh.Cells(i, col2).Value, "Down Pay", vbTextCompare) > 0 Or _
         InStr(1, sh.Cells(i, col2).Value, "Tax Adj", vbTextCompare) > 0 Or _
         InStr(1, sh.Cells(i, col3).Value, "Down Pay", vbTextCompare) > 0 Then
         Set rng = Union(rng, sh.Range("A" & i))
      End If
    
      '"=ISNUMBER(MATCH(RC[" & (Material - Service_Item) & "],'[Book1.xlsm]IMR Table'!C9,0))"
      If sh.Range("C" & i).Value <> "" Then
        Set f2 = Workbooks("Book1").Sheets("IMR Table").Range("I:I").Find( _
          sh.Range("C" & i).Value, , xlValues, xlWhole, , , False)
        If Not f2 Is Nothing Then Set rng = Union(rng, sh.Range("A" & i))
      End If
    Next
 
    rng.EntireRow.Delete
  'END DELETE ROWS
  
  Last_Row = sh.Range("a" & Rows.Count).End(xlUp).Row
  sh.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 3).Formula = "Blank Project ID?"
  Blank_Project_ID = sh.Rows(1).Find(What:="Blank Project ID?", LookAt:=xlWhole, MatchCase:=False).Column
  Project_ID = sh.Rows(1).Find(What:="Project ID?", LookAt:=xlWhole, MatchCase:=False).Column
  sh.Range(sh.Cells(2, Blank_Project_ID), sh.Cells(Last_Row, Blank_Project_ID)).FormulaR1C1 = _
    "=AND(VALUE(RC1)>0,LEN(RC[" & (Project_ID - Blank_Project_ID) & "])<2)"
  
  Application.ScreenUpdating = True
End Sub

🧙‍♂️
 
Upvote 0
Thanks so much Dante!!! Reading messages now in order to test and make sure I understand. Thank you!
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Solved
VBA of Match Formula using R1C1
Replies
2
Views
35
who am i
W
J
  • Solved
VBA Code Error Unable to get the Match property of the WorksheetFunction class
Replies
8
Views
232
Jiraya_00
J
S
  • Question Question
Multiple columns lookup
Replies
0
Views
252
Sipirili2504
S
H
  • Solved
Macro to improve Optimisation
Replies
3
Views
166
Alex Blakenburg
A
G
  • Solved
Adapt VBA code where "Find" is equal to a MID function (etc)
Replies
6
Views
266
GTS
G

Forum statistics

Threads
1,223,578
Messages
6,173,167
Members
452,504
Latest member
frankkeith2233

Share this page

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