I'm trying to get all possible combinations with a kind of VBA macro presented in https://stackoverflow.com/a/10693789/1992004, but get an error For without Next. I compared the source from another thread with mine, but don't found such difference, which could cause this error.
Do you see, what causes this error? - please point me to. My Code follows.
Option Explicit
Sub Sample()
Dim l As Long, m As Long, n As Long, o As Long, p As Long, q As Long, r As Long, s As Long, t As Long, u As Long
Dim CountComb As Long, lastrow As Long
Range("L2").Value = Now
Application.ScreenUpdating = False
CountComb = 0: lastrow = 18
For l = 1 To 1: For m = 1 To 2
For n = 1 To 2: For o = 1 To 18
For p = 1 To 15: For q = 1 To 10
For r = 1 To 10: For s = 1 To 17
For t = 1 To 3: For u = 1 To 3
Range("L" & lastrow).Value = Range("A" & l).Value & "/" & _
Range("B" & m).Value & "/" & _
Range("C" & n).Value & "/" & _
Range("D" & o).Value & "/" & _
Range("E" & p).Value & "/" & _
Range("F" & q).Value & "/" & _
Range("G" & r).Value & "/" & _
Range("H" & s).Value & "/" & _
Range("I" & t).Value & "/" & _
Range("J" & u).Value
lastrow = lastrow + 1
CountComb = CountComb + 1
Next: Next
Next: Next
Range("L1").Value = CountComb
Range("L3").Value = Now
Application.ScreenUpdating = True
End Sub
All the comments above explain your problem, but this is what your code would look like with proper indenting AND the missing "next" statements:
For l = 1 To 1
For m = 1 To 2
For n = 1 To 2
For o = 1 To 18
For p = 1 To 15
For q = 1 To 10
For r = 1 To 10
For s = 1 To 17
For t = 1 To 3
For u = 1 To 3
Range("L" & lastrow).Value = Range("A" & l).Value & "/" & _
Range("B" & m).Value & "/" & _
Range("C" & n).Value & "/" & _
Range("D" & o).Value & "/" & _
Range("E" & p).Value & "/" & _
Range("F" & q).Value & "/" & _
Range("G" & r).Value & "/" & _
Range("H" & s).Value & "/" & _
Range("I" & t).Value & "/" & _
Range("J" & u).Value
lastrow = lastrow + 1
CountComb = CountComb + 1
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
At the very least, it would have made it immediately obvious where your code was failing.
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 4 years ago.
Improve this question
I have a large excel VBA project that reads in several files and generates a new excel spreadsheet with several tabs. When run with weekly data it takes around 7 minutes to run. When run with monthly data it is taking almost 18 hours to run. It used to take over 30 hours, but thanks to several post on here I have been able to optimize it a lot. I have tried to make the project modular, and I can select which portions of the program I want to run each time it is run. It is the full run that takes the 18 hours. I wrote in a logging capability to see what was taking so long, and have found a portion of the program that takes about 11 hours to run. The issue is, if I select only that portion of the program to run by itself, it only takes 3 minutes to run. During the full run this portion is run later in the full process, so there are several tabs already created before this one is done. When run alone, there are only the two tabs that this portion creates. I'm trying to figure out why there would be such a huge difference in the processing time between running it by itself, and running it in the full process.
I have added the module in question. It's probably not real pretty, but it works. Again, 11 hours when run in the full process and about three minutes when run alone against the same data set.
Thanks,
Sub Upcoming()
Dim Days As Integer
Dim gd_lastrow As Long
'If Logging = True Then
' logIt (" Create new sheet")
'End If
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Coming Due"
Range("A1").Value = "IS Code"
Range("B1").Value = "Cage"
Range("C1").Value = "Contractor"
Range("D1").Value = "Contract Number"
Range("E1").Value = "Job #"
Range("F1").Value = "CLIN"
Range("G1").Value = "Due Date"
Range("H1").Value = "RDF"
Range("I1").Value = "Product"
Range("J1").Value = "Qty"
Range("K1").Value = "CA"
Rows("1:1").WrapText = True
Columns("B:B").ColumnWidth = 8
Columns("C:C").ColumnWidth = 46
Columns("D:D").ColumnWidth = 21
Columns("G:G").ColumnWidth = 18
Columns("H:H").ColumnWidth = 18
Columns("I:I").ColumnWidth = 15
Columns("F:F").ColumnWidth = 10
Columns("G:G").ColumnWidth = 21
Columns("K:K").ColumnWidth = 18
Columns("E:F").NumberFormat = "0000"
Columns("E:F").HorizontalAlignment = xlRight
Columns("G:H").NumberFormat = "[$-409]mmmm d, yyyy;#"
up_curline = 2
up_IS = ""
'Sheets("GD").Select
'gd_lastrow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
gd_lastrow = (Sheets("GD").UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
If myFileExists(myPath & "\GD.xlsx") Then
If Logging = True Then
logIt (" Prep the GD for vLookup")
End If
Sheets("GD").Select
If Range("BF6").Value = "" Then
For i = 6 To gd_lastrow
Range("BF" & i).Value = Range("F" & i).Value & Range("G" & i).Value & Range("T" & i)
Range("BG" & i).Value = Abs(Range("P" & i))
Range("BH" & i).Value = Range("F" & i).Value & Range("G" & i).Value & Range("U" & i)
Range("BI" & i).Value = Abs(Range("P" & i))
Next i
End If
End If
'If Logging = True Then
' logIt (" Get upcoming schedules or RDFs")
'End If
Sheets("DWR").Select
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
For i = 2 To up_lastRow 'Get upcoming RDF's
Sheets("DWR").Select
If Not IsError(Application.Match(Range("C" & i), Worksheets("CAR").Range("C:C"), 0)) Then 'Only get RDF's for the IS's in the CAR
If Not IsError(Application.Match(Range("G" & i), Worksheets("CAR").Range("H:H"), 0)) Then 'Only get RDFs for active contracts
If ((Range("K" & i) >= Now()) And (Range("K" & i) <= Now() + 90) And (Range("AE" & i) = "")) Or _
((Range("Q" & i) >= Now()) And (Range("Q" & i) <= Now() + 90) And (Range("AE" & i) = "")) Or _
((Range("AE" & i) >= Now()) And (Range("AE" & i) <= Now() + 90)) Then
Worksheets("Coming Due").Range("A" & up_curline) = Range("C" & i) 'IS
Worksheets("Coming Due").Range("B" & up_curline) = Range("E" & i) ' Cage
Worksheets("Coming Due").Range("C" & up_curline) = Range("D" & i) 'Contractor
Worksheets("Coming Due").Range("D" & up_curline) = Range("G" & i) ' Contract #
Worksheets("Coming Due").Range("F" & up_curline) = Range("J" & i) ' CLIN
If (Range("K" & i) = 0) Then
Worksheets("Coming Due").Range("G" & up_curline) = Range("Q" & i)
Sheets("Coming Due").Select
Range("H" & up_curline).Select
'Sheets("Coming Due").Range("H" & up_curline).ThemeColor = xlThemeColorDark1
'Sheets("Coming Due").Range("H" & up_curline).TintAndShade = -0.249977111117893
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Sheets("DWR").Select
Else
Worksheets("Coming Due").Range("G" & up_curline) = Range("K" & i) ' Due Date
End If
If Worksheets("Coming Due").Range("H" & up_curline) <> "Service CLIN" Then
Worksheets("Coming Due").Range("H" & up_curline) = Range("AE" & i) ' RDF
End If
If ((Worksheets("Coming Due").Range("H" & up_curline) = "") Or (Worksheets("Coming Due").Range("H" & up_curline)) = "Service CLIN") Then
Worksheets("Coming Due").Range("G" & up_curline).Style = "Neutral"
Else
Worksheets("Coming Due").Range("H" & up_curline).Style = "Neutral"
End If
'Worksheets("Coming Due").Range("I" & up_curline) = Range("V" & i) ' Item
If ((Range("N" & i) > 0) And (Range("N" & i) = Range("O" & i))) Then
Worksheets("Coming Due").Range("J" & up_curline) = "Shipped"
Else
'Worksheets("Coming Due").Range("J" & up_curline) = Range("N" & i) - Range("O" & i) ' Qty
On Error Resume Next
Err.Clear
Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & format(Worksheets("DWR").Range("J" & i), "0000") & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BF6:BG" & gd_lastrow), 2, 0)
If Err.Number <> 0 Then
Err.Clear
Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & Worksheets("DWR").Range("J" & i) & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BF6:BG" & gd_lastrow), 2, 0)
If Err.Number <> 0 Then
Err.Clear
Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & format(Worksheets("DWR").Range("J" & i), "0000") & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BH6:BI" & gd_lastrow), 2, 0)
If Err.Number <> 0 Then
Err.Clear
Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & Worksheets("DWR").Range("J" & i) & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BH6:BI" & gd_lastrow), 2, 0)
If Err.Number <> 0 Then
If Logging = True Then
logIt (" VlookUp Still Not Found")
logIt (" " & Err.Number & ": " & Err.Description)
logIt (" i = " & i)
logIt (" Contract = " & Worksheets("DWR").Range("G" & i).Value)
logIt (" CLIN = " & format(Worksheets("DWR").Range("J" & i), "0000"))
logIt (" Schedule Date = " & Worksheets("DWR").Range("K" & i))
logIt (" Lookup Value = " & Worksheets("DWR").Range("G" & i).Value & format(Worksheets("DWR").Range("J" & i), "0000") & Worksheets("DWR").Range("K" & i))
End If
End If
End If
End If
End If
On Error GoTo 0
End If
For o = 0 To 2000
If CDRLdata(o).contract = Worksheets("Coming Due").Range("D" & up_curline) Then
Worksheets("Coming Due").Range("E" & up_curline) = CDRLdata(o).job
Worksheets("Coming Due").Range("I" & up_curline) = CDRLdata(o).Product
Exit For
End If
Next o
up_curline = up_curline + 1
End If
End If
End If
Next i
Sheets("Coming Due").Select
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
'If Logging = True Then
' logIt (" Get service CLIN data")
'End If
Sheets("GD").Select 'Get service CLINs qty due
gd_lastrow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
For j = 2 To up_lastRow
If Worksheets("Coming Due").Range("J" & j) = 0 Then
For i = 6 To gd_lastrow
If ((Range("F" & i) = Worksheets("Coming Due").Range("D" & j)) And (Range("G" & i) = Worksheets("Coming Due").Range("F" & j)) And (Range("W" & i) = Worksheets("Coming Due").Range("G" & j))) Then
If ((Range("H" & i) > 0) And (Range("H" & i) = Range("I" & i))) Then
Worksheets("Coming Due").Range("J" & j) = "Shipped"
Else
Worksheets("Coming Due").Range("J" & j) = Range("H" & i) - Range("I" & i)
End If
End If
Next i
End If
Next j
For j = 2 To up_lastRow
If Worksheets("Coming Due").Range("J" & j) = "Shipped" Then
For i = 6 To gd_lastrow
If ((Range("F" & i) = Worksheets("Coming Due").Range("D" & j)) And (Range("G" & i) = Worksheets("Coming Due").Range("F" & j)) And (Range("U" & i) = Worksheets("Coming Due").Range("G" & j))) Then
If ((Range("N" & i) > 0) And (Range("N" & i) = Range("O" & i))) Then
Worksheets("Coming Due").Range("J" & j) = "Shipped"
Else
Worksheets("Coming Due").Range("J" & j) = Range("N" & i) - Range("O" & i)
End If
End If
Next i
End If
Next j
' Add any comments
'If Logging = True Then
' logIt (" Add comments to the list")
'End If
Dim tCLIN As String
Sheets("Coming Due").Select
commenttext = ""
cd_lastrow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
For r = 2 To cd_lastrow
For p = 0 To 2000
If CDRLdata(p).company = "" Then
Exit For
End If
' Contract level
If ((CDRLdata(p).contract = Worksheets("Coming Due").Range("D" & r)) And (CDRLdata(p).CoNotes <> "")) Then
commenttext = CDRLdata(p).contract & ": " & CDRLdata(p).CoNotes
temp2 = "D" & r
Set mycomment = Range(temp2).Comment
If mycomment Is Nothing Then
Range(temp2).AddComment
Range(temp2).Comment.Visible = False
Range(temp2).Comment.Text commenttext
Range(temp2).Comment.Shape.TextFrame.AutoSize = True
End If
End If
' CLIN Level
If CDRLdata(p).contract = Worksheets("Coming Due").Range("D" & r) Then
If Len(Worksheets("Coming Due").Range("F" & r)) = 1 Then
tCLIN = "000" & Worksheets("Coming Due").Range("F" & r)
Else
If Len(Worksheets("Coming Due").Range("F" & r)) = 2 Then
tCLIN = "00" & Worksheets("Coming Due").Range("F" & r)
Else
If Len(Worksheets("Coming Due").Range("F" & r)) = 3 Then
tCLIN = "0" & Worksheets("Coming Due").Range("F" & r)
Else
tCLIN = Worksheets("Coming Due").Range("F" & r)
End If
End If
End If
If ((CDRLdata(p).CLIN = tCLIN) And (tCLIN <> "")) Then
If CDRLdata(p).CdNotes <> "" Then
commenttext = CDRLdata(p).contract & " CLIN " & CDRLdata(p).CLIN & ": "
If CDRLdata(p).di <> "" Then
commenttext = commenttext & CDRLdata(p).di & " "
End If
commenttext = commenttext & CDRLdata(p).CdNotes
For q = p + 1 To 2000
If ((CDRLdata(q).contract = Worksheets("Coming Due").Range("D" & r)) And (CDRLdata(q).CLIN = Worksheets("Coming Due").Range("F" & r)) And (CDRLdata(q).CdNotes <> "")) Then
commenttext = commenttext & " " & " CLIN " & CDRLdata(q).CLIN & ": "
If CDRLdata(q).di <> "" Then
commenttext = commenttext & CDRLdata(q).di & " "
End If
commenttext = commenttext & CDRLdata(q).CdNotes
End If
Next q
temp2 = "F" & r
Set mycomment = Range(temp2).Comment
If mycomment Is Nothing Then
Range(temp2).AddComment
Range(temp2).Comment.Visible = False
Range(temp2).Comment.Text commenttext
Range(temp2).Comment.Shape.TextFrame.AutoSize = True
End If
Exit For
End If
End If
End If
Next p
Next r
'If Logging = True Then
' logIt (" Format comments")
'End If
Comments_Tom
'If Logging = True Then
' logIt (" Sort table by IS, Cage, Due date, Contract and CLIN")
'End If
Sheets("Coming Due").Select
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
For i = 2 To up_lastRow
If Range("H" & i) = "" Then
Range("M" & i) = Range("G" & i)
Else
If Range("H" & i) = "Service CLIN" Then
Range("M" & i) = Range("G" & i)
Else
Range("M" & i) = Range("H" & i)
End If
End If
Next
For i = 2 To up_lastRow
For p = 0 To 2000
' Get CA Name
If CDRLdata(p).contract = Worksheets("Coming Due").Range("D" & i) Then
If CDRLdata(p).Position1 = "Contract Administrator" Then
Range("K" & i) = CDRLdata(p).Name1
Else
If CDRLdata(p).Position2 = "Contract Administrator" Then
Range("K" & i) = CDRLdata(p).Name2
Else
If CDRLdata(p).Position3 = "Contract Administrator" Then
Range("K" & i) = CDRLdata(p).Name3
End If
End If
End If
Exit For
End If
Next p
Next i
'sort by IS, Cage, Due date, Contract, CLIN
Range("A2:M" & up_lastRow).Select
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
"A2:A" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
"B2:B" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
"M2:M" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
"D2:D" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
"F2:F" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Coming Due").Sort
.SetRange Range("A1:M" & up_lastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Save
' enter 30/60/90 day group headers
If Logging = True Then
logIt (" Enter 30/60/90 day headers")
End If
Sheets("Coming Due").Select
Range("A2").Select
up_curline = 2
up_IS = Range("A2")
up_cage = Range("B2")
up_Contract = Range("C2")
up_Due = Range("G2")
up_RDF = Range("H2")
up_Due = 0
up_RDF = 0
Rows("2:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
up_lastRow = up_lastRow + 3
up_curline = up_curline + 3
If ((Range("G" & up_curline) <= Now() + 30) And (Range("H" & up_curline) = "")) Then
Range("D" & up_curline - 2).Value = "Due within 30 days"
Days = 30
Else
If ((Range("G" & up_curline) <= Now() + 60) And (Range("H" & up_curline) = "")) Then
Range("D" & up_curline - 2).Value = "Due within 60 days"
Days = 60
Else
If Range("H" & up_curline) = "" Then
Range("D" & up_curline - 2).Value = "Due within 90 days"
Days = 90
End If
End If
End If
If (Range("H" & up_curline) <> "") Then
If Range("H" & up_curline) <= Now() + 30 Then
Range("D" & up_curline - 2).Value = "Due within 30 days"
Days = 30
Else
If Range("H" & up_curline) <= Now() + 60 Then
Range("D" & up_curline - 2).Value = "Due within 60 days"
Days = 60
Else
Range("D" & up_curline - 2).Value = "Due within 90 days"
Days = 90
End If
End If
End If
i = up_curline
Do Until IsEmpty(Cells(i, 1))
If Range("B" & i) <> up_cage Then
up_cage = Range("B" & i)
Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
up_lastRow = up_lastRow + 3
i = i + 3
If ((Range("G" & i) <= Now() + 30) And ((Range("H" & i) = "")) Or _
(((Range("H" & i) <> "")) And (Range("H" & i) <= Now() + 30))) Then
Range("D" & i - 2).Value = "Due within 30 days"
Days = 30
Else
If ((Range("G" & i) <= Now() + 60) And ((Range("H" & i) = "")) Or _
(((Range("H" & i) <> "")) And (Range("H" & i) <= Now() + 60))) Then
Range("D" & i - 2).Value = "Due within 60 days"
Days = 60
Else
Range("D" & i - 2).Value = "Due within 90 days"
Days = 90
End If
End If
End If
If (Days = 30) And _
(((Range("G" & i) > Now() + 30) And (Range("G" & i) <= Now + 60) And (Range("H" & i) = "")) Or _
((Range("H" & i) > Now() + 30) And (Range("H" & i) <= Now + 60) And (Range("H" & i) <> ""))) Then
Days = 60
Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
up_lastRow = up_lastRow + 3
i = i + 3
Range("D" & i - 2).Value = "Due within 60 days"
End If
If (Days = 30) And _
(((Range("G" & i) > Now() + 60) And (Range("G" & i) <= Now + 90) And (Range("H" & i) = "")) Or _
((Range("H" & i) > Now() + 60) And (Range("H" & i) <= Now + 90) And (Range("H" & i) <> ""))) Then
Days = 90
Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
up_lastRow = up_lastRow + 3
i = i + 3
Range("D" & i - 2).Value = "Due within 90 days"
End If
If (Days = 60) And _
(((Range("G" & i) > Now() + 60) And (Range("G" & i) <= Now + 90) And (Range("H" & i) = "")) Or _
((Range("H" & i) > Now() + 60) And (Range("H" & i) <= Now + 90) And (Range("H" & i) <> ""))) Then
Days = 90
Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
up_lastRow = up_lastRow + 3
i = i + 3
Range("D" & i - 2).Value = "Due within 90 days"
End If
i = i + 1
Loop
Columns("M:M").Delete
For i = 5 To up_lastRow
If Left(Range("D" & i), 10) = "Due within" Then
Range("G" & i - 1 & ":H" & i + 1).Style = "Normal"
End If
Next
Sheets("Coming Due").Select
ActiveCell.ClearComments
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveSheet.Name = "30-60-90 By Date"
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
Range("A1:K" & up_lastRow).Borders.LineStyle = xlContinuous
ActiveWorkbook.Save
' Create the 30-60-90 by Contract Tab
If Logging = True Then
logIt ("Begin Upcoming By Contract")
End If
Dim curCage As String
Dim curContract As String
Range("A1:K" & up_lastRow).Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = "30-60-90 By Contract"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
If Logging = True Then
logIt (" Begin Sorting By Contract")
End If
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Add Key:= _
Range("B5:B" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Add Key:= _
Range("D5:D" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Add Key:= _
Range("G5:G" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort
.SetRange Range("A5:K" & up_lastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("3:4").Delete Shift:=xlUp
If Logging = True Then
logIt (" Begin Deleting Blank Rows")
End If
For i = up_lastRow - 2 To 1 Step -1
If Range("A" & i).Value = "" Then
Rows(i & ":" & i).Delete Shift:=xlUp
Else
up_lastRow = i
Exit For
End If
If ((i Mod 200) = 0) Then
If Logging = True Then
logIt (" Line =" & i)
End If
End If
Next i
Range("A2").Select
ActiveWindow.FreezePanes = True
curCage = Range("B3").Value
curContract = Range("D3").Value
j = 4
If Logging = True Then
logIt (" Begin Looking For New CAGE or Contract Number")
End If
While Range("A" & j).Value <> ""
If Range("B" & j).Value <> curCage Then
curCage = Range("B" & j).Value
curContract = Range("D" & j).Value
Rows(j & ":" & j + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
j = j + 2
End If
If Range("D" & j).Value <> curContract Then
curContract = Range("D" & j).Value
Rows(j & ":" & j).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
j = j + 1
End If
j = j + 1
If ((j Mod 200) = 0) Then
If Logging = True Then
logIt (" Line =" & j)
End If
End If
Wend
End Sub
the VBA is kind of like Java which runs on JVM it is not really the CPU that does run it.
for example, consider the game speed when you would emulate PS3 on PC/Mac rather than using the real device (in short very slow).
what mean's VBA is already very slow and now your code does run on Excel and that will further slow everything since it will wait for Excel view/update.
my choice would be to rewrite your code using Qt and QtXlsxWriter.
although changing from VBA to C++ was a great step for me but the Qt libraries where/are even more clear to understand as VBA.
another option would be to provide your code so we see what is the problem but it looks like that is not an option ;-)
without the code's I think it has to do with VBA waiting for Excel update
I have pretty much solved my problem, but still do not have an answer to my question. I now have the monthly run being completed in less than 4 hours, and still see where other optimizations can be made. I primarily made three changes. First, I put in Application.Calculation = xlCalculationManual at the beginning of the module that was taking so long, and set it back to automatic at the end of the module. This cut the 11 hours down to around 4 to 5 hours. I had read a lot on optimization, but the comment above was the first time I had heard of this. Next I moved this module up to the beginning of the run. Recall that running this module later in the full run took 11 hours, but when run alone, it only took around three minutes. When run as the first module, in the full run it just takes three to four minutes. And finally, I rewrote the module to use 2D array instead of inserting and deleting rows and columns in the worksheets. The module now takes around 1 minute. From 11 + hours to 1 minute is pretty good I'm thinking. But the question is still there. Why did moving the module from later in the run to first cause such a big difference, especially when recalc was set to manual. Is it memory management? Is it ????? I dunno, but I'm very happy with the results.
I have a sheet "result" and another sheet "status".
The sheet "status" has a table with column A as calendar week.
The idea is to copy the count values of column K, of the "result" sheet to the data sheet.
Similarly other count values in other columns as well.
The code is working fine with no errors.
The problem is I get an error with two of my values.
CntT acc.to code is providing me with "93" actually , I have "95"
similarly cntS acc to code is providing me "49" while actually I have "50".
Could anyone help me to figure out where I am wrong.I already posted this question and checked with the feedback. It dint work for me.
Sub result()
Dim i As Integer
Dim j As Integer
Dim cnt As Integer
Dim cntU As Integer
Dim sht As Worksheet
Dim TotalRows As Long
Set sht = Sheets("Status")
Sheets("Result").Select
TotalRows = Range("E5").End(xlDown).Row
n = Worksheets("Result").Range("E5:E" & TotalRows).Cells.SpecialCells(xlCellTypeConstants).Count
For i = 2 To WorksheetFunction.Count(sht.Columns(1))
cntT = 0
cntU = 0
cntS = 0
If sht.Range("A" & i) = Val(Format(Now, "WW")) Then Exit For
Next i
For j = 4 To WorksheetFunction.CountA(Columns(17))
If sht.Range("A" & i) = Range("Q" & j) And Range("K" & j) = "Green" Then cntT = cntT + 1
If sht.Range("A" & i) = Range("Q" & j) And Range("J" & j) = "delayed" Then cntU = cntU + 1
If sht.Range("A" & i) = Range("Q" & j) And Range("A" & j) = "" Then cntS = cntS + 1
If cntT <> 0 Then sht.Range("C" & i) = cntT
If cntU <> 0 Then sht.Range("D" & i) = cntU
If cntS <> 0 Then sht.Range("B" & i) = cntS
If n <> 0 Then sht.Range("E" & i) = n
Next j
If cntT + cntU <> 0 Then
sht.Range("F" & i) = (cntS / n)
sht.Range("G" & i) = (cntT / n)
sht.Range("H" & i) = (cntS / n)
sht.Range("G" & i & ":F" & i & ":H" & i).NumberFormat = "0.%"
End If
'sht.Range("G" & i & ":F" & i & ":H" & i).NumberFormat = "0.%"
End Sub
I have the below VBA script. It's simply moving information from one sheet to another. However, I want each cell moved to possess the same color and font in sheet2 as it had in sheet1. Cherry on top, when moving cells if I could get the script to skip over blank cells that would be amazing.
Sub Example()
lr = Sheets("Sheet1").Range("Z65536").End(xlUp).Row
k = 0
For i = 5 To lr
k = k + 1
Sheets("Sheet2").Range("A" & k) = Sheets("Sheet1").Range("Z" & i)
Sheets("Sheet2").Range("B" & k) = Sheets("Sheet1").Range("Z" & i)
Sheets("Sheet2").Range("C" & k) = Sheets("Sheet1").Range("Z" & i)
Sheets("Sheet2").Range("D" & k) = Sheets("Sheet1").Range("Z" & i)
k = k + 1
Sheets("Sheet2").Range("A" & k) = Sheets("Sheet1").Range("AA" & i)
Sheets("Sheet2").Range("B" & k) = Sheets("Sheet1").Range("AA" & i)
Sheets("Sheet2").Range("C" & k) = Sheets("Sheet1").Range("AA" & i)
Sheets("Sheet2").Range("D" & k) = Sheets("Sheet1").Range("AA" & i)
Next
End Sub
Replace lines like:
Sheets("Sheet2").Range("A" & k) = Sheets("Sheet1").Range("Z" & i)
with:
Sheets("Sheet1").Range("Z" & i).Copy Sheets("Sheet2").Range("A" & k)
will maintain color and font.
I am running a for...next loop that checking whether entries in a dataset meet a certain condition (in this case IsNA). However, changing the if-then-else conditions within this loop to also check whether a condition is not met seems to break the for/next loop. I receive a Next without For error even though that element of the sub hasn't changed.
I'm lost as to why the it thinks there is no next in the for loop when that part of the code hasn't changed.
--Original Working Code--
Option Explicit
Dim i As Double
Dim a As Range
Public ssht As Worksheet
Public susht As Worksheet
Public mdsht As Worksheet
Public LastRow As Long
Dim testcell As Long
Public Sub MissingDataSetCopy()
'Part Bii
'Find rows with NA error
Application.ScreenUpdating = False
Dim i, j As Integer
j = 4
'Finds current range on Summary worksheet
Set ssht = ThisWorkbook.Worksheets("sandbox")
Set mdsht = ThisWorkbook.Worksheets("MissingData")
Set susht = ThisWorkbook.Worksheets("summary")
'Copies data to sandbox sheet as values
susht.UsedRange.copy
ssht.Range("A1").PasteSpecial (xlPasteValues)
LastRow = ssht.Range("A4").CurrentRegion.Rows.Count
Dim testcell As Double
Dim numchk As Boolean
'For...Next look call ISNUMBER test
For i = 860 To 874
If Application.WorksheetFunction.IsNA(ssht.Range("B" & i)) Then
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i - 1 & ":G" & i - 1).Value
j = j + 1
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i & ":G" & i).Value
j = j + 1
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i + 1 & ":G" & i + 1).Value
j = j + 1
End If
Next i
Dim fnd As Variant
Dim rplc As Variant
fnd = "#N/A"
rplc = "=NA()"
mdsht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
End Sub
--Edit to If Statements--
For i = 860 To 874
If Application.WorksheetFunction.IsNA(ssht.Range("B" & i)) And Application.WorksheetFunction.IsNA(ssht.Range("B" & i - 1)) Then
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i & ":G" & i).Value
j = j + 1
If Application.WorksheetFunction.IsNA(ssht.Range("B" & i)) And Not (Application.WorksheetFunction.IsNA(ssht.Range("B" & i - 1))) Then
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i - 1 & ":G" & i - 1).Value
j = j + 1
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i & ":G" & i).Value
j = j + 1
End If
Next i
You need to close the second If block:
For i = 860 To 874
If Application.WorksheetFunction.IsNA(ssht.Range("B" & i)) And Application.WorksheetFunction.IsNA(ssht.Range("B" & i - 1)) Then
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i & ":G" & i).Value
j = j + 1
End If '<-- it was not closed
If Application.WorksheetFunction.IsNA(ssht.Range("B" & i)) And Not (Application.WorksheetFunction.IsNA(ssht.Range("B" & i - 1))) Then
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i - 1 & ":G" & i - 1).Value
j = j + 1
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i & ":G" & i).Value
j = j + 1
End If
Next i
Or alternatively using the ElseIf keyword if the two conditions (at it seems) are excluding each other:
For i = 860 To 874
If Application.WorksheetFunction.IsNA(ssht.Range("B" & i)) And Application.WorksheetFunction.IsNA(ssht.Range("B" & i - 1)) Then
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i & ":G" & i).Value
j = j + 1
ElseIf Application.WorksheetFunction.IsNA(ssht.Range("B" & i)) And Not (Application.WorksheetFunction.IsNA(ssht.Range("B" & i - 1))) Then
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i - 1 & ":G" & i - 1).Value
j = j + 1
mdsht.Range("B" & j & ":H" & j).Value = ssht.Range("A" & i & ":G" & i).Value
j = j + 1
End If
Next i