+ Reply to Thread
Results 1 to 9 of 9

Can someone help speed up my code?

Hybrid View

  1. #1
    Registered User
    Join Date
    02-14-2013
    Location
    arlington
    MS-Off Ver
    Excel 2010
    Posts
    20

    Unhappy Can someone help speed up my code?

    I have a spreadsheet with travel information and I wrote code to loop through and find the specific columns I am looking for and then analyze them based on the criteria provided. I am relatively new to VBA and I am assuming there is a faster way to do this. Currently it takes about 69 seconds to execute. I dont want to use specific columns in case someone deletes a column that isnt needed. Any suggestions? Thanks

     Sub CreateSheetsWithNames()
    sheets("master").Cells.EntireColumn.Hidden = False
    
        Dim firstrow As Range
        Dim rcell As Range
    Dim rcell2 As Range
    Dim rcell3 As Range
    Dim rcell4 As Range
    Dim rcell5 As Range
      Dim rcell6 As Range
     Dim rcell7 As Range
    Dim rcell8 As Range
    Dim rcell9 As Range
    Dim rcell10 As Range                    
                       
        Dim bcell As Range
     Dim bcell2 As Range
    Dim bcell3 As Range
    Dim bcell4 As Range
    Dim bcell5 As Range
    Dim bcell6 As Range
    Dim Bcell7 As Range
     Dim Bcell8 As Range
      Dim Bcell9 As Range
     Dim Bcell10 As Range                         
     Dim myrange As Long
    Dim myrange2 As Long
    Dim myrange3 As String
     Dim myrange4 As String
        Dim strnsearch As String
            Dim strnsearch2 As String
                Dim strnsearch3 As String
                    Dim strnsearch4 As String
    Dim strnsearch5 As String
      Dim strnsearch6 As String
       Dim strnsearch7 As String
    Dim strnsearch8 As String
    Dim strnsearch9 As String
     Dim strnsearch10 As String
     
        Dim ws As Worksheet
        Dim cvalue As String 
        Dim LastRow As Long
            Dim lastcolumn1 As Long
        Dim y As Long
        With sheets("master")
     
    If .Range("b1") = "" Then
        lastcolumn1 = .Range("b1").End(xlDown).End(xlToRight).Column
            Else      
    lastcolumn1 = .Range("b1").End(xlToRight).Column
        End If
    
    If .Range(Cells(1, lastcolumn1).Address) = "" Then
        Set firstrow = .Range(Cells(1, lastcolumn1).Address).End(xlDown).Offset(0, 1)
                Else:  Set firstrow = .Range(Cells(1, lastcolumn1).Offset(0, 1).Address)
                    End If
                    
    For y = firstrow.Row To .Range("A100000").End(xlUp).Row
     
    strnsearch = "Document Type"
     Set bcell = .Rows().Find(What:=strnsearch, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
       If Not bcell Is Nothing Then
        bcellletter = Col_Letter(bcell.Column)
             Else
                MsgBox ("Please designate column 'Document Type'")
                    End
                        End If
                                                    
    strnsearch2 = "Expenses by LOA"
        Set bcell2 = .Rows().Find(What:=strnsearch2, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
    If Not bcell2 Is Nothing Then
       bcellletter2 = Col_Letter(bcell2.Column)
            Else
                MsgBox ("Please designate column 'Expenses by LOA'")
                     End
                        End If
    
    strnsearch3 = "Document Create Date"
        Set bcell3 = .Rows().Find(What:=strnsearch3, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
    
    If Not bcell3 Is Nothing Then
        bcellletter3 = Col_Letter(bcell3.Column)
             Else
                MsgBox ("Please designate column 'Document Create Date'")
                 End
                        End If
    
    strnsearch4 = "Departure Date"
        Set bcell4 = .Rows().Find(What:=strnsearch4, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
    If Not bcell4 Is Nothing Then
        bcellletter4 = Col_Letter(bcell4.Column)
            Else
                MsgBox ("Please designate column 'Departure Date'")
                     End
                        End If
                        
    strnsearch5 = "Last AO Approved Date"
        Set bcell5 = .Rows().Find(What:=strnsearch5, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
     If Not bcell5 Is Nothing Then
        bcellletter5 = Col_Letter(bcell5.Column)
     Else
     MsgBox ("Please designate column 'Last AO Approved Date'")
     End
    End If
                                      
    strnsearch6 = "Total Trip Expenses"
        Set bcell6 = .Rows().Find(What:=strnsearch6, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                 
    If Not bcell6 Is Nothing Then
       bcellletter6 = Col_Letter(bcell6.Column)
     Else
    MsgBox ("Please designate column 'Total Trip Expenses'")
    End
     End If
                                                           
    strnsearch7 = "TANum"
        Set Bcell7 = .Rows().Find(What:=strnsearch7, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
    If Not Bcell7 Is Nothing Then
        bcellletter7 = Col_Letter(Bcell7.Column)
    Else
     MsgBox ("Please designate column 'TANum'")
     End
    End If
                                                          
    strnsearch8 = "Total Reimbursable Expenses"
        Set Bcell8 = .Rows().Find(What:=strnsearch8, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
    If Not Bcell8 Is Nothing Then
        bcellletter8 = Col_Letter(Bcell8.Column)
            Else
     MsgBox ("Please designate column 'Total Reimbursable Expenses'")
     End
    End If
                                                 
    strnsearch9 = "Return Date"
        Set Bcell9 = .Rows().Find(What:=strnsearch9, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
    
    If Not Bcell9 Is Nothing Then
        bcellletter9 = Col_Letter(Bcell9.Column)
            Else
     MsgBox ("Please designate column 'Return Date'")
    End
    End If
    
    strnsearch10 = "Current Status"
        Set Bcell10 = .Rows().Find(What:=strnsearch10, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                                                                
    If Not Bcell10 Is Nothing Then
        bcellletter10 = Col_Letter(Bcell10.Column)
            Else
                MsgBox ("Please designate column 'Current Status'")
                     End
                        End If
                                          
    LastLetter = Col_Letter(lastcolumn1)
    clearletter = Col_Letter(firstrow.Column)
    
    firstrow.Value = "AUTHORIZATIONS"
    firstrow.Offset(0, 1).Value = "VOUCHERS"
    firstrow.Offset(0, 2).Value = "LOCAL VOUCHERS"
    firstrow.Offset(0, 3).Value = "Doc create date after departure date"
    firstrow.Offset(0, 4).Value = "Travel Notice Given"
    firstrow.Offset(0, 5).Value = "Voucher Create date over 5 days from Return"
    firstrow.Offset(0, 6).Value = "Last AO approved Date before  Doc Create Date"
    firstrow.Offset(0, 7).Value = "Is Cancelled Trip Zero'd Out?"
    firstrow.Offset(0, 8).Value = "Unliquidated Amount"
    firstrow.Offset(0, 9).Value = "Unliquidated %"
    Range(firstrow, firstrow.Offset(0, 9)).Font.Bold = True
     
    For Each rcell In .Range(bcellletter & y)
    For Each rcell2 In .Range(bcellletter2 & y)
    For Each rcell3 In .Range(bcellletter3 & y)
    For Each rcell4 In .Range(bcellletter4 & y)
    For Each rcell5 In .Range(bcellletter5 & y)
    For Each rcell6 In .Range(bcellletter6 & y)
    For Each rcell7 In .Range(bcellletter7 & y)
    For Each rcell8 In .Range(bcellletter8 & y)
    For Each rcell9 In .Range(bcellletter9 & y)
    For Each rcell10 In .Range(bcellletter10 & y)
    
    If rcell.Value = "AUTH" Then
        .Range(LastLetter & y).Offset(0, 1).Value = .Range(bcellletter2 & y).Value
            End If
    If rcell.Value = "VCH" Then
        .Range(LastLetter & y).Offset(0, 2).Value = .Range(bcellletter2 & y).Value
            End If
    If rcell.Value = "LVCH" Then
        .Range(LastLetter & y).Offset(0, 3).Value = .Range(bcellletter2 & y).Value
            End If
            
    If rcell.Value = "AUTH" And rcell4.Value < rcell3.Value Then
        .Range(LastLetter & y).Offset(0, 4).Value = "Error"
            End If
    
    If rcell.Value = "AUTH" Then
        If rcell5.Value < rcell3.Value And rcell6.Value > 0 And rcell10.Value = "CANCELLED" Then
            .Range(LastLetter & y).Offset(0, 7).Value = "Error"
                End If
                    End If
                             
    If rcell.Value = "VCH" Or rcell.Value = "LVCH" Then
        If rcell3.Value - rcell9.Value > 5 Then
            .Range(LastLetter & y).Offset(0, 6).Value = "Error"
                End If
                    End If
    '                         
    If rcell7.Value = " " Or rcell7.Value = "" And rcell2.Value > 0 Then
        .Range(LastLetter & y).Offset(0, 8).Value = .Range(bcellletter2 & y)
            .Range(LastLetter & y).Offset(0, 8).NumberFormat = "$#,##0.00"
                End If
                        
    If rcell.Value = "AUTH" Then
        .Range(LastLetter & y).Offset(0, 5).Value = rcell4.Value - rcell3.Value
            .Range(LastLetter & y).Offset(0, 5).HorizontalAlignment = xlCenter
                End If
                 
    Next
    Next
    Next
    Next
    Next
    Next
    Next
    Next
    Next
    Next
    Next
    End With
    end sub
    Last edited by Ppessina; 08-21-2013 at 04:27 PM.

  2. #2
    Forum Guru
    Join Date
    03-02-2006
    Location
    Los Angeles, Ca
    MS-Off Ver
    Win10/MSO2016
    Posts
    13,000

    Re: Can someone help speed up my code?

    Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

    Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

    Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here
    Ben Van Johnson

  3. #3
    Registered User
    Join Date
    02-14-2013
    Location
    arlington
    MS-Off Ver
    Excel 2010
    Posts
    20

    Re: Can someone help speed up my code?

    Sorry about that. Corrected

  4. #4
    Forum Expert
    Join Date
    03-28-2012
    Location
    TBA
    MS-Off Ver
    Office 365
    Posts
    12,454

    Re: Can someone help speed up my code?

    I have not look at the entire code, but what is .Rows().?
    Why can not you specify the row number? If you can not, I would use .usedrange, instead of rows().

  5. #5
    Registered User
    Join Date
    02-14-2013
    Location
    arlington
    MS-Off Ver
    Excel 2010
    Posts
    20

    Re: Can someone help speed up my code?

    I am using .rows to find which row my text is in. I am trying to avoid putting row and column numbers in because the data contains a lot of misc info and if somone deletes a column it will cause errors. I am thinking maybe if the code is restructured and I am able to clear some of the memory this will speed things up but I am not sure how i would do it. I will try .usedrange in the mean time to see if this makes a difference.
    Last edited by Ppessina; 08-21-2013 at 05:00 PM.

  6. #6
    Forum Expert
    Join Date
    03-28-2012
    Location
    TBA
    MS-Off Ver
    Office 365
    Posts
    12,454

    Re: Can someone help speed up my code?

    You also have 10 nested loop. This obviously slows the code as it loop 10 times the number of rows.
    IMO, You would better-off by dividing the code in to 2-3 parts and linking each code by calling one another. It is easy to follow and adjust few many small codes than one massive and thick code.

  7. #7
    Registered User
    Join Date
    02-14-2013
    Location
    arlington
    MS-Off Ver
    Excel 2010
    Posts
    20

    Re: Can someone help speed up my code?

    That is a good idea. I will try this as well. Thank you

  8. #8
    Valued Forum Contributor
    Join Date
    07-17-2005
    Location
    Abergavenny, Wales, UK
    MS-Off Ver
    XL2003, XL2007, XL2010, XL2013, XL2016
    Posts
    608

    Re: Can someone help speed up my code?

    Hi

    In addition to what has already been said, you are doing far too much reading and writing.
    Every time you read from the Sheet, and every time you write to the sheet you are incurring an enormous overhead in crossing the VBA / Sheet interface.
    You should read all of your data into an array.
    You should then dimension an output array of the appropriate size to take your result.
    All of the processing of the array should then happen within VBA, and only when you have your Output array, should it then be written back to the sheet with one single command.

    That would speed up your code by a huge magnitude.
    --
    Regards
    Roger Govier
    Microsoft Excel MVP

  9. #9
    Registered User
    Join Date
    02-14-2013
    Location
    arlington
    MS-Off Ver
    Excel 2010
    Posts
    20

    Re: Can someone help speed up my code?

    Thank you for the information. Can you show me an example of how to do this with one of the loops in the above code? I am not sure how to tackle this. I have been researching it but still cant seem to get it. I broke the above code into 3 sections instead of one and it only sped up by 5 seconds so that did not do me any good.
    Last edited by Ppessina; 08-22-2013 at 12:33 AM.

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] How to Speed Up the code ?
    By joh46k in forum Excel Programming / VBA / Macros
    Replies: 5
    Last Post: 04-03-2013, 09:42 PM
  2. Way to speed up VBA code
    By lalbatros in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 08-12-2007, 03:10 AM
  3. speed up my code?
    By mpeplow in forum Excel Programming / VBA / Macros
    Replies: 5
    Last Post: 06-18-2007, 09:07 PM
  4. Speed up Code?
    By Sige in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 07-27-2005, 02:05 PM
  5. [SOLVED] Speed up code
    By Derick Hughes in forum Excel Programming / VBA / Macros
    Replies: 0
    Last Post: 02-08-2005, 02:06 PM

Tags for this Thread

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1