VBA Offset within Loop - taking forever to run - vba

I'm brand new to programming, and I figured VBA is a good place for me to start since I do a lot of work in Excel.
I created a macro that takes an integer from an input box (I've been using 2, 3 and 4 to test) and it creates a set of a 4-tier hierarchy of that number; e.g. entering "2" would produce
1.0.0.0
1.0.0.1
1.0.0.2
1.0.1.0
1.0.1.1
1.0.1.2 etc.
I got the macro to work as intended, but it takes forever to run. I think it's the offsets within the loops that are slowing it down. Does anyone have any suggestions to speed this up? Any general feedback is welcome as well.
Sub Tiers()
'Input Box
Dim Square As Integer
Square = InputBox("Enter Number of Tiers")
Range("f5").Select
Selection.Value = 0
With Application
.ScreenUpdating = False
End With
'Rows down
Dim g As Integer
Dim h As Integer
Dim i As Integer
Dim j As Integer
'Start For loops
For g = 1 To Square
For h = 0 To Square
For i = 0 To Square
For j = 0 To Square
'calculate offsets and place values of loop variables
Dim step As Long
step = ((g - 1) * (Square + 1) ^ 3 - 1 + (h * (Square + 1) ^ 2) + Square * i + i + j + 1)
Selection.Offset(step, 0).Value = j
Selection.Offset(step, -1).Value = i
Selection.Offset(step, -2).Value = h
Selection.Offset(step, -3).Value = g
Next j
Next i
Next h
Next g
With Application
.ScreenUpdating = True
End With
End Sub
Thanks

Further to my comment below your post, looping and writing to sheets like this will be too slow. Write to an array and then write the array to worksheet. This ran in a blink of an eye.
Is this what you are trying?
Sub Sample()
Dim TempArray() As Long
Dim n As Long
Dim g As Long, h As Long, i As Long, j As Long
Dim reponse As Variant
'~~> Accept only numbers
reponse = Application.InputBox(Prompt:="Enter Number of Tiers", Type:=1)
If reponse <> False Then
For g = 1 To reponse
For h = 0 To reponse
For i = 0 To reponse
For j = 0 To reponse
n = n + 1
Next j
Next i
Next h
Next g
ReDim Preserve TempArray(1 To n, 1 To 4)
n = 1
For g = 1 To reponse
For h = 0 To reponse
For i = 0 To reponse
For j = 0 To reponse
TempArray(n, 1) = g
TempArray(n, 2) = h
TempArray(n, 3) = i
TempArray(n, 4) = j
n = n + 1
Next j
Next i
Next h
Next g
'~~> Replace this with the relevant sheet
Sheet1.Range("A1").Resize(UBound(TempArray), 4).Value = TempArray
End If
End Sub
Screenshot:

The step calculation seems superfluous:
step = ((g - 1) * (Square + 1) ^ 3 - 1 + (h * (Square + 1) ^ 2) + Square * i + i + j + 1)
Try the following:
Sub Tiers()
'Input Box
Dim Square As Long
Square = InputBox("Enter Number of Tiers")
With Application
.ScreenUpdating = False
End With
'Rows down
Dim g As Long
Dim h As Long
Dim i As Long
Dim j As Long
Dim step As Long
step = 1
For g = 1 To Square
For h = 0 To Square
For i = 0 To Square
For j = 0 To Square
Range("F5").Offset(step, 0).Value = j
Range("F5").Offset(step, -1).Value = i
Range("F5").Offset(step, -2).Value = h
Range("F5").Offset(step, -3).Value = g
step = step + 1
Next j
Next i
Next h
Next g
With Application
.ScreenUpdating = True
End With
End Sub

Related

EXCEL VBA FOR inside IF

Never used VBA before and basically just trying write this sub:
Sub Populate_Empties()
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim m As Integer
Dim k As Integer
' test for 50 rows...then change i from 2 to 278970
m = 2
For k = 3 To 8
For i = 2 To 50
If (IsEmpty(Cells(i, k).Value)) Then
m = i 'any statement
Else
j = i - 1
For n = m To j
Cells(n, k).Value = Cells(i, k).Value
m = i + 1
End If
End Sub
I keep getting error End If without Block
Any suggestions?
You're missing the closing statements on your for loops
Sub Populate_Empties()
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim m As Integer
Dim k As Integer
' test for 50 rows...then change i from 2 to 278970
m = 2
For k = 3 To 8
For i = 2 To 50
If (IsEmpty(Cells(i, k).Value)) Then
m = i 'any statement
Else
j = i - 1
For n = m To j
Cells(n, k).Value = Cells(i, k).Value
Next n
m = i + 1
End If
Next i
Next k
End Sub

Macro does not execute completely

I have been working on a macro that Archives: it selects rows with the right cell value and move them to another tab (while deleting the rows in the tab of origin).
My macro was working perfectly fine, but I decided to change my file and have different new tabs. When I computed my Macro in my new tabs, and it works on the right rows, and deletes them, but does not copy them in my "Archive tab" :
Sub Archive_Ongoing()
Test 2 : works for 2 arguments.
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("B90_Projects_OnGoing").UsedRange.Rows.Count
J = Worksheets("B90_Projects_Archived").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("B90_Projects_Archived").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("B90_Projects_OnGoing").Range("O1:O" & I)
Set yRg = Worksheets("B90_Projects_OnGoing").Range("T1:T" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Closed" And CStr(yRg(K).Value) <> "" Then
xRg(K).Selection.Copy Destination:=Worksheets("B90_Projects_Archived").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Closed" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub'
Any one would be able to explain why?
Because you're decrementing your K variable within the FOR loop, which is also incrementing it. Your K variable never changes. Comment out K = K - 1 and report back?
If you're doing that on purpose to evaluate / delete a single line and shift the next values up then you might want to have a K2 variable that you increment like this:
For K = 1 To xRg.Count
If CStr(xRg(K - K2).Value) = "Closed" And CStr(yRg(K - K2).Value) <> "" Then
xRg(K - K2).Selection.Copy Destination:=Worksheets("B90_Projects_Archived").Range("A" & J + 1)
xRg(K - K2).EntireRow.Delete
If CStr(xRg(K - K2).Value) = "Closed" Then
K2 = K2 + 1
End If
J = J + 1
End If
Next

Find Method Object Variable Not Set

This is an error I've been trying to figure out for awhile now, my find method is not producing any results and I cannot figure out why.
The code is suppose to search InputSheet for a string, report the row number and start moving information over to Background based on that row number. Then the next .find will find the string in SummaryResults and start moving information from Background, reformat it a bit, and paste to SummaryResults.
My find method is not producing any results and leaves FindRow = Nothing even though the strings are present in the sheets and in the correct Ranges.
This error started occurring after running the macro with another Excel sheet open so maybe the ActiveWorkbook was incorrect, but I have not been able to get it to run since.
Some of the variables shown are from other sections of the code but when I hover over them in the debug mode they are showing what they're suppose to.
Option Explicit
Sub CAESARCONVERSION()
Dim InputSheet As Worksheet, SummaryResults As Worksheet, Background As Worksheet
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
Dim h As Integer
Dim v As Integer
Dim c As Integer
Dim z As Integer
Dim myBook As Workbook
Set myBook = Excel.ThisWorkbook
Set InputSheet = myBook.Sheets("Input Sheet")
Set SummaryResults = myBook.Sheets("Summary Results")
Set Background = myBook.Sheets("Background")
Dim NodeList As Integer
Dim TotalCases As Integer
Dim sMyString As String
Dim Nodes As Variant
Dim FindRow As Range
Dim intValueToFind As String
Dim FindRowNumber As Long
Dim SecondRowNumber As Long
'Clear the last run of macro
Background.Range("A2:A1000").Cells.Clear
Background.Range("C2:I10000").Cells.Clear
SummaryResults.Cells.Clear
'Code that will count the total number of load cases
TotalCases = 0
h = 2
Dim text As String
For v = 12 To 100
If InputSheet.Cells(v, 2).Value <> "" Then
text = LTrim(InputSheet.Cells(v, 2).Value)
Background.Cells(h, 3).Value = text
h = h + 1
TotalCases = TotalCases + 1
Else
GoTo NodeCounter
End If
Next v
NodeCounter:
y = TotalCases - 1
x = 0
Dim LoadCaseList() As Variant
ReDim LoadCaseList(y)
LoadCaseList:
For x = 0 To y
LoadCaseList(x) = Background.Cells(2 + x, 3).text
Next x
j = 2
For i = 17 + TotalCases To 20000 'Need to define how far for the program to search, we may exceed 20000 at some point
If InputSheet.Cells(i, 2).Value <> "" Then
Background.Cells(j, 1).Value = InputSheet.Cells(i, 2).Value
j = j + 1
End If
Next i
With Background
NodeList = Background.Cells(2, 2).Value
Background.Range("AA1:XX" & NodeList + 1).Cells.Clear
End With
ReDim Nodes(NodeList - 1)
v = 0
j = 2
For i = 0 To NodeList - 1
Nodes(i) = Background.Cells(j, 1).Value
j = j + 1
Next i
Headers:
Dim LoadCaseHeader() As String
Dim TypHeader()
TypHeader = Array("Node", "L", "Direction", "Magnitude")
Dim LoadDirections()
LoadDirections = Array("X", "Y", "Z", "MX", "MY", "MZ")
x = 0
z = 0
For x = 0 To NodeList - 1
For z = 0 To TotalCases - 1
SummaryResults.Range(("B" & 2 + (NodeList * 6 + 2) * z) & ":" & "E" & 2 + (NodeList * 6 + 2) * z) = TypHeader()
SummaryResults.Range("A" & 2 + (NodeList * 6 + 2) * z) = Background.Range("C" & 2 + z)
Next z
Next x
'Search rows for the first instance of this value.
LoadCases:
'Code that copies information from the InputSheet to the SummaryResults
Dim LoadCases() As Long
ReDim LoadCases(NodeList, 6)
FindRowNumber = 0
SecondRowNumber = 0
For c = 0 To y
intValueToFind = LoadCaseList(c)
For i = 7 To 31 + TotalCases
With InputSheet
If Trim(Cells(i, 3).Value) = intValueToFind Then
MsgBox ("Found")
Set FindRow = InputSheet.Range("C:C").Find(What:=intValueToFind, LookIn:=xlValues)
FindRowNumber = FindRow.Row
End If
End With
Next i
'MsgBox FindRowNumber
With InputSheet
For i = 0 To NodeList - 1
x = 4
For j = 0 To 5
LoadCases(i, j) = InputSheet.Cells(FindRowNumber + (TotalCases + 3) * i, x)
x = x + 1
Next j
Next i
End With
Background.Range("AC2:AH" & NodeList + 1).Offset(0, c * 7) = LoadCases
For i = 1 To NodeList * 6 * TotalCases
With SummaryResults
If Trim(Cells(i, 5).Value) = intValueToFind Then
Set FindRow = SummaryResults.Range("A:A").Find(What:=intValueToFind, LookIn:=xlValues)
SecondRowNumber = FindRow.Row
GoTo Step2
End If
End With
Next i
Step2:
With SummaryResults
For x = 0 To NodeList - 1
For j = 0 To 5
SummaryResults.Cells(SecondRowNumber + 1 + j + 6 * x, 5) = Background.Cells(x + 2, 29 + j)
SummaryResults.Cells(SecondRowNumber + 1 + j + 6 * x, 3) = TypHeader(1)
SummaryResults.Cells(SecondRowNumber + 1 + j + 6 * x, 4) = LoadDirections(j)
SummaryResults.Cells(SecondRowNumber + 1 + j + 6 * x, 2) = Nodes(x)
Next j
Next x
End With
Next c
End Sub
Any help would be appreciated. EDIT: Uploaded the entire code. Additional information, the code works when not tabbed into excel but will fail when tabbed in a ran again.
The issue seems to be that the LoadCaseList() array is never getting populated. This is your Find statement:
Set FindRow = InputSheet.Range("C:C").Find(What:=intValueToFind, LookIn:=xlValues)
intValueToFind is set by this statement:
intValueToFind = LoadCaseList(c)
But the LoadCaseList() array is populated by the following code which is a label that is never called by a GoTo statement (as far as I can tell):
LoadCaseList:
For x = 0 To y
LoadCaseList(x) = Background.Cells(2 + x, 3).text
Next x
So because the LoadCaseList label statement is never being called by a GoTo statement, the LoadCaseList() array is never being populated so intValueToFind has no value and therefore the Find method has no value to search for (except for maybe the empty string).

Calculating a Sum

What I am trying to do is develop a model that takes a cell that is greater than 1 then to take the sum of the area to the first row using a cone shape, so for example cell D4, sum the area C3:C5 + B2:B6 + A1:A7.
At the moment I have this but it obviously is not working.
Dim I As Double
Dim J As Double
Dim Size As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
'Dim Range As Integer
Dim PV1 As Integer
'MCArray = Worksheets("Data")
I = WorksheetFunction.CountA(Worksheets("Data").Rows(1))
J = WorksheetFunction.CountA(Worksheets("Data").Columns(1))
'Loop to Move down the rows
For x = 1 To J
'Loop to move acoss the columns
For y = 1 To I
'IfElse to determine if cell value is greater or equal to zero
If Cells(J, I).Value >= 0 Then
'Loop to sum the cells above
For z = 1 To J
PV1 = (ActiveCell.Value) + Worksheet.Sum(Range([J - z], [I-z:I+z]))
'IfElse to determine if final sum is greater than zero
If PV1 > 0 Then
Worksheets("MC").Range("B4").Value = PV1
Range([J - z], [I-z:I+z]).Interior.ColourIndex = 1
End If
Next z
End If
Next y
Next x
Here is a function you can use either as a UDF or from another routine. Just pass it the single cell you want to start from (D4 in your example) and this function will calculate the sum of the cone as you described.
Public Function SUMCONE(r As Range) As Double
Application.Volatile
SUMCONE = Application.Sum(r, r(-0, -0).Resize(, 3), r(-1, -1).Resize(, 5), r(-2, -2).Resize(, 7))
End Function
Here is an example of how to use the above function from your VBA routine:
Public Sub Demo()
Dim j&
For j = 5 To 10
If Cells(5, j) > 0 Then
Debug.Print SUMCONE(Cells(5, j))
End If
Next
End Sub
UPDATE
Based on your feedback I have updated the function and the demo routine to form an upward cone summation from the initial cell.
UPDATE #2
The above is for a fixed-size cone, extending upwards, that can be initiated from any cell in the worksheet.
But if you would prefer for the cone to always extend all the way up to row 1 regardless of which cell it originates in, then the following is what you are after:
Public Sub Demo()
Dim i&, j&
For j = 1 To Application.CountA(Worksheets("Data").Rows(1))
For i = 1 To Application.CountA(Worksheets("Data").Columns(1))
If Cells(i, j) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
UPDATE #3
As I suspected there was a problem if the cone was initiated too close to the left edge of the worksheet. I've added code to handle that now. Also your method for accessing the large matrix (which I had used in the Demo routine) did not work properly. I fixed that as well:
Public Sub Demo()
Dim i&, j&
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Val(Cells(i, j)) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
If r.Column - k < 2 Then Exit For
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function

Is there a way to impose a time limit for the code in VBA?

I was wondering if anyone had any experience imposing time limits on sections of code. I have programmed a search engine into an excel spreadsheet in VBA and there is a section of the code that removes duplicate results. Now this part can sometimes stretch on for quite a long time if given the most vague search criteria. So I would like to impose a time limit for this operation. I have looked everywhere for a solution and tried using OnTime, but it doesnt seem to work in the way I need. Ideally, I'd like an imposed time limit and then when that is reached a GoTo statement, to move it further on in the code. From what I have read the OnTime will not interrupt an operation, but will wait for it to finish instead, this is not what I want.
Thanks for your help guys.
Amy
I've added my code:
Sub RemoveDuplicates()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'Code called upon through the other macros which will remove duplicates from all the types of search.
Application.StatusBar = "Removing Duplicates...."
Dim k As Integer
Dim SuperArray As String
Dim CheckingArray As String
Dim Duplicate As Boolean
Dim i As Integer
Dim j As Integer
Dim m As Integer
Dim Endrow As Integer
Dim Endcolumn As Integer
Dim w As Integer
Dim x As Integer
Dim n As Integer
w = 1
x = 9
Endcolumn = Module6.Endcolumn(x)
Endrow = Module6.Endrow(w)
If Worksheets("Search Engine").Cells(9, Endrow) = "Percentage Similarity" Then
Endrow = Endrow - 1
End If
For i = 9 To Endcolumn
j = 1
k = i + 1
Do While j <> Endrow + 1
SuperArray = Cells(i, j) & Superstring
Superstring = SuperArray
j = j + 1
Loop
For k = k To Endcolumn
m = 1
Do While m <> Endrow
CheckingArray = Cells(k, m) & Uberstring
Uberstring = CheckingArray
m = m + 1
Loop
If Uberstring = Superstring Then
n = 1
Do While n <> Endrow + 1
If Worksheets("Search Engine").Cells(k, n).Interior.ColorIndex = 37 Then
Worksheets("Search Engine").Cells(i, n).Interior.ColorIndex = 37
End If
n = n + 1
Loop
Rows(k).Clear
End If
Uberstring = -1
Next k
Superstring = -1
Next i
Do While i > 9
If Cells(i, 1) = Empty Then
Rows(i).Delete
End If
i = i - 1
Loop
End Sub
I assume your code must have some kind of loop, e.g. For Each, While ... Wend, Do ... Loop Until, etc.
In theses cases, extend the condition by a comparison to the Timer. This returns you a Double between 0 and 86400, indicating how many seconds have passed since midnight. Thus, you also need to account for the day break. Here is some example code showing you implementations for three different loop constructs:
Sub ExampleLoops()
Dim dblStart As Double
Dim tmp As Long
Const cDblMaxTimeInSeconds As Double = 2.5
dblStart = Timer
'Example with For loop
For tmp = 1 To 1000
tmp = 1 'to fake a very long loop, replace with your code
DoEvents 'your code here
If TimerDiff(dblStart, Timer) > cDblMaxTimeInSeconds Then GoTo Finalize 'Alternative: Exit For
Next
'Alternative example for Do loop
Do
DoEvents 'your code here
Loop Until TimerDiff(dblStart, Timer) > cDblMaxTimeInSeconds And False 'your condition here
'Alternative example for While loop
While TimerDiff(dblStart, Timer) <= cDblMaxTimeInSeconds And True 'your condtion here
DoEvents 'your code here
Wend
Finalize:
'FinalizeCode here
Exit Sub
End Sub
Function TimerDiff(dblTimerStart As Double, dblTimerEnd As Double)
Dim dblTemp As Double
dblTemp = dblTimerEnd - dblTimerStart
If dblTemp < -43200 Then 'half a day
dblTemp = dblTemp + 86400
End If
TimerDiff = dblTemp
End Function