VBA Improve For Loop

Ottsel

Ottsel

Board Regular
Joined
Jun 4, 2022
Messages
177
Office Version
  1. 365
Platform
  1. Windows
I have this for loop that creates a workbook reference using data from columns A, B, and C. I've dimmed strings to make a structure.

Would there be a way to step away from my for loop and going into a whole column paste instead?

For example: have the macro select from row 12 down to the selected 'row' and just make all the formulas by column instead of having to loop through each and every row. This way it would only loop through columns D:K.

The reason: on my main computer this works fine, but on my other this macro takes a very long time to complete when I have over 500 rows of data to reference.

Here's my working code currently; any help, tips or advice would be greatly appreciated!

VBA Code: 
    Dim r As Long 'row
    Dim row As Long 'row count
    Dim FormulaStart As String
    Dim FormulaHook As String
    Dim Address As String
    Dim Ph1Num As String
    Dim Ph1Hrs As String
    Dim Ph2Num As String
    Dim Ph2Hrs As String
    Dim Ph3Num As String
    Dim Ph3Hrs As String

    row = Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
    FormulaStart = "='G:\JOBCARDS\"
    'Builder = Range("A" & r).Value & "\"
    'Tract = Range("B" & r).Value & "\[Lot"
    'LotNum = Range("C" & r).Value
    FormulaHook = ".xls]"
    Address = "LCV'!$M$3"
    Ph1Num = "JobCard'!$H$30"
    Ph1Hrs = "JobCard'!$G$30"
    Ph2Num = "JobCard'!$H$64"
    Ph2Hrs = "JobCard'!$G$64"
    Ph3Num = "JobCard'!$H$91"
    Ph3Hrs = "JobCard'!$G$91"
    Siding = "JobCard'!$D$70"
    
    '...Prevent from Forumlas filling all the way down
    'Application.AutoCorrect.AutoFillFormulasInLists = False
    Application.DisplayAlerts = False

    For r = 12 To row + 12
        If Len(ActiveSheet.Range("A" & r).Value) > 0 Then
            Range("D" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Address
            Range("E" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph1Num
            Range("F" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph1Hrs
            Range("G" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph2Num
            Range("H" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph2Hrs
            Range("Z" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Siding
            If Range("Z" & r).Value > 0 Then
                Range("I" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph3Num
                Range("J" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph3Hrs
                Range("K" & r).Formula = "=IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=100%),""Done"",IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=""n/a""),""Done"",""""))"
                Range("A" & r).Activate
            Else
                Range("I" & r).Value = "n/a"
                Range("J" & r).Value = "n/a"
                Range("K" & r).Formula = "=IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=100%),""Done"",IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=""n/a""),""Done"",""""))"
                Range("A" & r).Activate
            End If
        End If
    Next r
 
Sort by date Sort by votes
Try this
VBA Code: 
Dim r As Long 'row
    Dim row As Long 'row count
    Dim FormulaStart As String
    Dim FormulaHook As String
    Dim Address As String
    Dim Ph1Num As String
    Dim Ph1Hrs As String
    Dim Ph2Num As String
    Dim Ph2Hrs As String
    Dim Ph3Num As String
    Dim Ph3Hrs As String
    Application.ScreenUpdating = False
    row = Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
    FormulaStart = "='G:\JOBCARDS\"
    'Builder = Range("A" & r).Value & "\"
    'Tract = Range("B" & r).Value & "\[Lot"
    'LotNum = Range("C" & r).Value
    FormulaHook = ".xls]"
    Address = "LCV'!$M$3"
    Ph1Num = "JobCard'!$H$30"
    Ph1Hrs = "JobCard'!$G$30"
    Ph2Num = "JobCard'!$H$64"
    Ph2Hrs = "JobCard'!$G$64"
    Ph3Num = "JobCard'!$H$91"
    Ph3Hrs = "JobCard'!$G$91"
    Siding = "JobCard'!$D$70"
    
    '...Prevent from Forumlas filling all the way down
    'Application.AutoCorrect.AutoFillFormulasInLists = False
    Application.DisplayAlerts = False

    For r = 12 To row + 12
        If Len(ActiveSheet.Range("A" & r).Value) > 0 Then
            Range("D" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Address
            Range("E" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph1Num
            Range("F" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph1Hrs
            Range("G" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph2Num
            Range("H" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph2Hrs
            Range("Z" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Siding
            If Range("Z" & r).Value > 0 Then
                Range("I" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph3Num
                Range("J" & r).Value = FormulaStart & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & FormulaHook & Ph3Hrs
                Range("K" & r).Formula = "=IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=100%),""Done"",IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=""n/a""),""Done"",""""))"
                Range("A" & r).Activate
            Else
                Range("I" & r).Value = "n/a"
                Range("J" & r).Value = "n/a"
                Range("K" & r).Formula = "=IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=100%),""Done"",IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=""n/a""),""Done"",""""))"
                Range("A" & r).Activate
            End If
        End If
    Next r
    Application.ScreenUpdating = True
 
Upvote 0
@Ottsel test if this shortened version of your code still works correctly:

VBA Code: 
    Dim r               As Long 'row
    Dim row             As Long 'row count
    Dim FormulaStart    As String
'
    Application.ScreenUpdating = False
'
    row = Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
'
    For r = 12 To row + 12
        If Len(ActiveSheet.Range("A" & r).Value) > 0 Then
            FormulaStart = "='G:\JOBCARDS\" & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & ".xls]"
            
            Range("D" & r).Value = FormulaStart & "LCV'!$M$3"
'
            Range("E" & r).Value = FormulaStart & "JobCard'!$H$30"
            Range("F" & r).Value = FormulaStart & "JobCard'!$G$30"
'
            Range("G" & r).Value = FormulaStart & "JobCard'!$H$64"
            Range("H" & r).Value = FormulaStart & "JobCard'!$G$64"
'
            Range("Z" & r).Value = FormulaStart & "JobCard'!$D$70"
'
            If Range("Z" & r).Value > 0 Then
                Range("I" & r).Value = FormulaStart & "JobCard'!$H$91"
                Range("J" & r).Value = FormulaStart & "JobCard'!$G$91"
            Else
                Range("I" & r & ":J" & r).Value = "n/a"
            End If
'
            Range("K" & r).Formula = "=IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=100%),""Done"",IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=""n/a""),""Done"",""""))"
        End If
    Next
'
    Application.Goto Range("A" & r)
'
    Application.ScreenUpdating = True
 
Upvote 0
Solution
johnnyL said:
@Ottsel test if this shortened version of your code still works correctly:

VBA Code: 
    Dim r               As Long 'row
    Dim row             As Long 'row count
    Dim FormulaStart    As String
'
    Application.ScreenUpdating = False
'
    row = Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
'
    For r = 12 To row + 12
        If Len(ActiveSheet.Range("A" & r).Value) > 0 Then
            FormulaStart = "='G:\JOBCARDS\" & Range("A" & r).Value & "\" & Range("B" & r).Value & "\[Lot" & Range("C" & r).Value & ".xls]"
           
            Range("D" & r).Value = FormulaStart & "LCV'!$M$3"
'
            Range("E" & r).Value = FormulaStart & "JobCard'!$H$30"
            Range("F" & r).Value = FormulaStart & "JobCard'!$G$30"
'
            Range("G" & r).Value = FormulaStart & "JobCard'!$H$64"
            Range("H" & r).Value = FormulaStart & "JobCard'!$G$64"
'
            Range("Z" & r).Value = FormulaStart & "JobCard'!$D$70"
'
            If Range("Z" & r).Value > 0 Then
                Range("I" & r).Value = FormulaStart & "JobCard'!$H$91"
                Range("J" & r).Value = FormulaStart & "JobCard'!$G$91"
            Else
                Range("I" & r & ":J" & r).Value = "n/a"
            End If
'
            Range("K" & r).Formula = "=IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=100%),""Done"",IF(AND(E" & r & "=100%,G" & r & "=100%,I" & r & "=""n/a""),""Done"",""""))"
        End If
    Next
'
    Application.Goto Range("A" & r)
'
    Application.ScreenUpdating = True
Click to expand...
I disabled the screenupdating. It copies column D:H as the same before, so it'll update to what the prior one was for all, but for some odd reason I:J seems to be the only accurate information.

So, the percentage and numbers for the top row for example should be: 85% | 62 | 12% | 5 | n/a | n/a
the n/a's are correct, but I was hoping it would do what the other columns are doing, which is it copies to the very bottom row instantly, but with accurate information and not the same all the way down.
Here's a snippet:
1677177878889.png
 
Upvote 0
Are you saying that the shortened code I provided doesn't provide the same results as the code that you provided in post #1?

Edit: Can you post the result with XL2BB please.
 
Last edited:
Upvote 0
johnnyL said:
Are you saying that the shortened code I provided doesn't provide the same results as the code that you provided in post #1?

Edit: Can you post the result with XL2BB please.
Click to expand...
I found the issue with why this was occurring.
Application.AutoCorrect.AutoFillFormulasInLists = False
was causing the issue and i just completely overlooked it.

yours appears to run smoother on my older system. Thank you for the setup! I'll have to try applying that format to my other projects.
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
Error in Macro request to delete all rows between two specific text values whose rows are dynamic
Replies
5
Views
134
Joe4
Joe4
A
  • Question Question
Looking to improve procedure
Replies
4
Views
158
AlexanderBB
A
E
  • Solved
How to specify multiple separate cells for copy in VBA
Replies
4
Views
358
Ed Harris
E
lojanica
  • Question Question
How to execute VBA every 10 minutes?
3 4 5
Replies
40
Views
976
Edgar_
Edgar_
montecarlo2012
  • Question Question
change display from horizontal to vertical
Replies
2
Views
190
montecarlo2012
montecarlo2012

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