Making Macro More Efficient?

[CyrusTheVirus]

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?

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

 

[CyrusTheVirus]

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]

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.