Making Macro More Efficient?

CyrusTheVirus

Well-known Member
Joined
Jan 28, 2015
Messages
737
Office Version
  1. 365
Platform
  1. Windows
The below macro takes around 8-18 seconds to run. Total number of rows will be around 2,000.

Curious if anyone has any ideas on how to alter the code to make it run even quicker. It seems to be the second for next loop that takes the bulk of the time.

Is 8-18 seconds normal for a code like this?

Code:
Sub Employee()

Dim Employee As Worksheet, Upload As Worksheet, Voucher As Worksheet
Dim lrowrange As Long, lrow As Long, lrow2 As Long, lrow3 As Long, lrow4 As Long, lrow5 As Long, lrow6 As Long
Dim lrow7 As Long, lrow8 As Long, lrow9 As Long, lrow10 As Long, lrow11 As Long, lrow12 As Long, lrow13 As Long
Dim DeleteRange As Range, AddRow As Range


Set Employee = ThisWorkbook.Worksheets("Employee")
Set Upload = ThisWorkbook.Worksheets("Upload")
Set Voucher = ThisWorkbook.Worksheets("Voucher")
Set DeleteRange = ThisWorkbook.Names("GL_Description").RefersToRange
Set AddRow = ThisWorkbook.Names("Add_Row").RefersToRange






    'Prepare the Voucher worksheet for the next macro run. The reason for repeating the third step twice...
    '...(once now and once more below) is due to Excel having an issue with inserting a table formatted row...
    '...on the first try after all of the rows within the table have been deleted.
    
        DeleteRange.Value = 0
        
        DeleteRange.EntireRow.Delete
                    
        Voucher.Range("B6:C11").ClearContents
                  
            
            
    'Bring over the information from the Employee worksheet to the Voucher worksheet


        Voucher.Range("B6:B9").Value = Employee.Range("B6:B9").Value
            
        Voucher.Range("C10").Value = Employee.Range("B10").Value






    'Set the long lrowrange on the Employee worksheet
        
        With Employee
            lrowrange = .Range("A" & .Rows.Count).End(xlUp).Row
        End With






    'Bring over the information from the Employee worksheet to the Voucher worksheet.


        For i = 20 To lrowrange


            If Employee.Rows(i).EntireRow.Hidden = False Then
                
                AddRow.Offset(-1, -1).Value = Employee.Cells(i, 5).Value
                AddRow.Offset(-1, 0).Value = Employee.Cells(i, 7).Value
                AddRow.Offset(-1, 0).ListObject.ListRows.Add AlwaysInsert:=False
                    
            End If
        
        Next i
                        
                                           
                                           
    'To take away an extra rows the might have been caused by the previous section.
             
        If AddRow.Offset(-1, 0).Value = "" Then
        
            AddRow.Offset(-1, 0).EntireRow.Delete
        
        End If
                            
                            


    'Bring over the information from the Employee worksheet to the Upload worksheet.
    
    


        For i = 20 To lrowrange


            With Upload
            
                lrow1 = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                lrow2 = .Range("B" & .Rows.Count).End(xlUp).Row + 1
                lrow3 = .Range("C" & .Rows.Count).End(xlUp).Row + 1
                lrow4 = .Range("D" & .Rows.Count).End(xlUp).Row + 1
                lrow5 = .Range("E" & .Rows.Count).End(xlUp).Row + 1
                lrow6 = .Range("F" & .Rows.Count).End(xlUp).Row + 1
                lrow7 = .Range("G" & .Rows.Count).End(xlUp).Row + 1
                lrow8 = .Range("H" & .Rows.Count).End(xlUp).Row + 1
                lrow9 = .Range("I" & .Rows.Count).End(xlUp).Row + 1
                lrow10 = .Range("J" & .Rows.Count).End(xlUp).Row + 1
                lrow11 = .Range("K" & .Rows.Count).End(xlUp).Row + 1
                lrow12 = .Range("L" & .Rows.Count).End(xlUp).Row + 1
                lrow13 = .Range("M" & .Rows.Count).End(xlUp).Row + 1
                
            End With


            If Employee.Rows(i).EntireRow.Hidden = False Then


                Upload.Range("A" & lrow1).Value = Employee.Range("B6")
                Upload.Range("B" & lrow2).Value = "Invoice"
                Upload.Range("C" & lrow3).Value = Employee.Range("B7").Value
                Upload.Range("D" & lrow4).Value = Employee.Range("B8").Value
                Upload.Range("E" & lrow5).Value = Employee.Range("B10").Value
                Upload.Range("F" & lrow6).Value = 50
                Upload.Range("G" & lrow7).Value = Employee.Cells(i, 7).Value
                Upload.Range("H" & lrow8).Value = Employee.Cells(i, 7).Value
                Upload.Range("I" & lrow9).Value = Employee.Cells(i, 5).Value
                Upload.Range("J" & lrow10).Value = 6
                Upload.Range("K" & lrow11).Value = Employee.Cells(i, 7).Value
                Upload.Range("L" & lrow12).Value = 0
                Upload.Range("M" & lrow3).Value = Employee.Range("B7").Value


            End If


        Next i
        
        


        Voucher.Range("B6").Value = Employee.Range("B8")


        Employee.Range("B7,B8,B12,B13").ClearContents


        Application.CutCopyMode = False
        
        MsgBox "The macro ran successfully."


        MsgBox "Please print the voucher for authorization."
        


End Sub
 

Some videos you may like

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

CyrusTheVirus

Well-known Member
Joined
Jan 28, 2015
Messages
737
Office Version
  1. 365
Platform
  1. Windows
Please ignore this note
'Prepare the Voucher worksheet for the next macro run. The reason for repeating the third step twice... '...(once now and once more below) is due to Excel having an issue with inserting a table formatted row... '...on the first try after all of the rows within the table have been deleted.
 

CyrusTheVirus

Well-known Member
Joined
Jan 28, 2015
Messages
737
Office Version
  1. 365
Platform
  1. Windows
I just realized that I do not need all of these lrows. I just need a few 3, since they will all be using the same row number.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,135
Messages
5,599,917
Members
414,348
Latest member
KloppyM

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
Top