Results 1 to 9 of 9

Can someone help speed up my code?

Threaded 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.

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