My function looks like this:
Sub sortNumbers()
Dim i As Integer
Dim j As Integer
Dim highestNumber As Integer
For i = 1 To 8
If IsEmpty(Cells(i + 4, 6).Value) = False Then
If Cells(i + 3, 6).Value > Cells(i + 4, 6).Value Then
highestNumber = Cells(i + 3, 6).Value
Cells(i + 3, 6).Value = Cells(i + 4, 6).Value
Cells(i + 4, 6).Value = highestNumber
End If
End If
Next i
For j = 1 To 8
If IsEmpty(Cells(j + 4, 6).Value) = False Then
If Cells(i + 3, 6).Value > Cells(i + 4, 6).Value Then
Call sortNumbers
Else
Exit Sub
End If
End If
Next j
End Sub
Everything gets sorted properly, but right after I get a message saying Out of stack space
Any help would be much appreciated!
EDIT
The excel sample data looks like this:
test data
1
100
1000
8
9
9
50
100
500
(from F3-F12)
If you remove the IsEmpty lines, Empty cells will be treated as 0. If you wish to leave them blank and sort around them you will need to impliment additional logic.
Your second loop needed to be adjusted. As it stood, the first time
call 1:
The first loop would give:
1 100 8 9 9 50 100 500 1000
Then the second loop would get to 1 > 100 and exit sub.
BUT... its best not to simply remove the exit sub call.
Its more efficient to only recall sortNumbers once per call.
If you had simply removed the exit sub.
then the second loop would get to 100 > 8 and trigger a recursion (Call 2).
Call 2:
the first loop would give:
1 8 9 9 50 100 100 500 1000
then the second loop would determine that Cells(i + 3,6) is never > Cells(i + 4,6) and exit Sub.
Since the 2nd call has returned we resume Call 1 where we left off. This means we finish the 2nd loop.
If this were a larger dataset you could have hundreds of recursions required to sort the dataset. When the last call (lets say its the 104th call) returns the previous 103 calls to the routine would all finish their 2nd loops (which since the 104th call returned, the data is already sorted, and thus is a waste)
The second loop should simply check to see if a recall is nessisary and if so, recall sortNumbers one time.
Sub sortNumbers()
Dim i As Integer
Dim j As Integer
Dim highestNumber As Integer
For i = 1 To 8
If Cells(i + 3, 6).value > Cells(i + 4, 6).value Then
highestNumber = Cells(i + 3, 6).value
Cells(i + 3, 6).value = Cells(i + 4, 6).value
Cells(i + 4, 6).value = highestNumber
End If
Next i
Dim ReCall As Boolean
ReCall = False
For i = 1 To 8
If Cells(i + 3, 6).value > Cells(i + 4, 6).value Then
ReCall = True
i = 8
End If
Next i
If ReCall Then Call sortNumbers
End Sub
Related
I have a dataset of 40,000 rows of data. My code is set so that it checks if the date in row n+1 is 1 day after the date in row n. If the dates in rows n and n+1 do not follow in normal chronological order, then it adds a row with blank data for that date.
My issues is that because I am adding rows along as I go, I have no idea what the ending range my for loop should have. I also tried just setting a really large range like "For n = 2 to 50000". But this gives me an overflow error.
Here is my code:
Sub MissingDates()
Dim n As Integer
Worksheets("sheet1").Activate
For n = 2 To 40000
If Cells(n, 2).Value <> Cells(n + 1, 2).Value - 1 Then
Cells(n + 1, 2).EntireRow.Insert Shift:=xlShiftDown
Cells(n + 1, 2) = Cells(n, 2) + 1
End If
Next
End Sub
Thank you in advance for any help.
A signed integer does not reach 40,000 and you should work from the bottom up.
Option Explicit
Sub MissingDates()
Dim n As Long, m As Long
With Worksheets("sheet1")
For n = .Cells(.Rows.Count, "B").End(xlUp).Row - 1 To 2 Step -1
For m = .Cells(n + 1, "B").Value2 - 1 To .Cells(n, "B").Value2 + 1 Step -1
.Cells(n + 1, 2).EntireRow.Insert Shift:=xlShiftDown
.Cells(n + 1, 2) = m
Next m
Next n
End With
End Sub
The overflow error comes because you declare n As Integer (i.e. 32,767) but you push it until 40,000. You can solve that by declaring n As Long instead.
As for your problem, you rather want a While loop instead of a For one. It should look something like this:
n = 2 '<- your starting value
Do While Cells(n+1,2).Value <> "" '<-- I guess you stop when there's no more value in your row
If Cells(n, 2).Value <> Cells(n + 1, 2).Value - 1 Then
Cells(n + 1, 2).EntireRow.Insert Shift:=xlShiftDown
Cells(n + 1, 2) = Cells(n, 2) + 1
End If
n = n + 1 '<-- increment n
Loop
I'm trying to implement a nested for and a nested if statement together. I have the following column below. It needs to look at the column if the range is between 500-1000 it should give recommendation a (i.e. write the recommendation in another column) if it is more than 1000 it should give another recommendation in the responding column.
Income Recommendation
550 a
1200 b
750 a
1400 b
600 a
Dim i As Integer
Dim j As Integer
For i = 2 To Range(i, 1).End(xlDown).Row
If Cells(i, 1).Value > 1000 Then
Cells(i, 10).Value = "b"
i = i + 1
Else
If Cells(i, 1).Value < 1000 Then
If Cells(i, 1).Valie > 500 Then
Cells(i, 10).Value = "a"
End If
End If
i = i + 1
End If
Next i
End Sub
Several errors:
Don't rely on i having a value while it is setting the start and end values of the For loop - there is a good chance that it is 0 while calculating Range(i, 1). (Edit: Tested and confirmed that it is still 0 at the point when the end value is being calculated.) Using Range(0, 1) will give a 1004 error.
Don't increment the loop counter within the loop (i.e. don't do i = i + 1) - it will almost certainly confuse things. If you really only want to process every second row, use Step 2 on the For statement.
.Valie should be .Value
Don't use Integer data types for rows - these days Excel can handle 1048576 rows, which is more than an Integer can cope with.
Range(1, 1) is invalid syntax. When passing two parameters to the Range property, they need to be cell references. Passing a row and column is what is used when using the Cells property. (So Range(1, 1) will need to be Cells(1, 1), or Range("A1").)
Refactoring your code would give:
Dim i As Long
For i = 2 To Cells(1, "A").End(xlDown).Row
If Cells(i, "A").Value > 1000 Then
Cells(i, "J").Value = "b"
ElseIf Cells(i, "A").Value > 500 Then
Cells(i, "J").Value = "a"
Else
Cells(i, "J").Value = ""
End If
Next i
End Sub
You can do it like this with Select Case:
Public Sub TestMe()
Dim i As Long
Dim j As Long
With ActiveSheet
For i = 2 To .Cells(1, 1).End(xlDown).Row
Select Case True
Case .Cells(i, 1) > 1000
.Cells(i, 10) = "b"
Case .Cells(i, 1) < 1000 And .Cells(i, 1) > 500
.Cells(i, 10).value = "a"
End Select
Next i
End With
End Sub
It is more visible and a bit more understandable. Also, make sure that you refer to the Worksheet (in this case with ActiveSheet), to avoid reference problems in the future.
I have to insert missing dates to a row without deleting the duplicated dates (for a billing program). Example data:
DATE
01/02/2016
02/02/2016
03/02/2016
03/02/2016
03/02/2016
06/02/2016
07/02/2016
08/02/2016
My code is infinitely looping and deleting the duplicate dates. Why does this happen?
Sub InsertMissingDates()
Dim i As Long
Dim RowCount As Long
i = 4
Do
If Cells(i, 1) + 1 <> Cells(i + 1, 1) Then
Rows(i + 1).Insert
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
i = i + 1
Loop Until Cells(i + 1, 1) = "31.10.2016"
End Sub
Here is the code modified with comments to address your issues
Sub InsertMissingDates()
Dim i As Long
Dim RowCount As Long
i = 4
Do
'Use less then instead of <> so it doesn't flag duplicate cells
If Cells(i, 1) + 1 < Cells(i + 1, 1) Then
Rows(i + 1).Insert
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
'Second check to add value if the next row is blank
If (Cells(i + 1, 1) = "") Then
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
i = i + 1
'Changed the loop function from cells(i+1,1) to cells(i,1) since you already
'incremented i
'Also made the date check slightly more robust with dateserial
Loop Until Cells(i, 1).Value >= DateSerial(2016, 1, 30)
End Sub
Sub project()
Dim a, deltat_value1, deltat_value2, deltat_value3 As Integer
a = 2
Do
deltat_value1 = Cells(a, 7).Value
deltat_value2 = Cells(a + 1, 7).Value
deltat_value3 = Cells(a + 2, 7).Value
If Abs(deltat_value1 - deltat_value2) > 5 And Abs(deltat_value2 - deltat_value3) > 5 Then
Rows(a + 1).EntireRow.Delete
End If
a = a + 1
Loop Until deltat_value1 = 14700
End Sub
I am trying to delete the noisy data, I set if a data point that it has a difference bigger than 5 from both the points above and below it, that is a noisy data and I set to delete the whole row of the noisy data.
However, I am having this problem for the line:
deltat_value3=Cells(a+2,7).Value
Runtime Error 1004 "Application-defined or Object-defined error"
And the running takes extremely longer time. I am a new user of VBA programming and I think my method may be inefficient, there may be other ways work much better, any advice?
How about:
Sub ytrewq()
Dim a As Long, deltat_value1 As Long, deltat_value2 As Long, deltat_value3 As Long
Dim rKill As Range
a = 2
Do
deltat_value1 = Cells(a, 7).Value
deltat_value2 = Cells(a + 1, 7).Value
deltat_value3 = Cells(a + 2, 7).Value
If Abs(deltat_value1 - deltat_value2) > 5 And Abs(deltat_value2 - deltat_value3) > 5 Then
If rKill Is Nothing Then
Set rKill = Cells(a + 1, 1)
Else
Set rKill = Union(rKill, Cells(a + 1, 1))
End If
End If
a = a + 1
Loop Until deltat_value1 = 14700
rKill.EntireRow.Delete
End Sub
Ok so I'm definitely a novice at VBA but I'm learning. As far as I can tell there no reason my code shouldn't be running fine, and has in the past. This error keeps popping up though. What the intention is I'm making a sheet that automatically updates the other sheets when you add a person to the main sheet. The code seems to work and has, but it is suddenly throwing this error and I can't figure out why. I've looked around but none of the solutions seem to be remotely relevant to my issue. Any help at figuring out exactly where the error is would be greatly appreciated!
The following is where the debugger is saying the error is:
Private Sub Worksheet_Activate()
ThisWorkbook.UpdateSheets (Week2)
End sub
And this is the function being called:
Public Function UpdateSheets(ByRef w As Worksheet)
HowManyPeople
With w
.Columns("A:W").HorizontalAlignment = xlCenter
Dim i As Integer
Dim j As Integer
For i = 1 To x
If IsEmpty(.Cells(i, 2)) Then
For j = 2 To 12
.Cells(i + 4, j).Borders.LineStyle = xlContinuous
If j <> 12 Then
.Cells(i + 4, j).Interior.ColorIndex = 2
.Cells(i + 4, j).Locked = False
Else
.Cells(i + 4, j).Interior.ColorIndex = 15
.Cells(i + 4, j).Locked = True
End If
If j = 2 Then
.Cells(i + 4, j).Value = Week1.Cells(i + 4, j)
Else
.Cells(i + 4, j).Value = "0"
End If
Next j
End If
Next i
i = x + 5
Do
For j = 2 To 12
.Cells(i, j).Borders.LineStyle = xlNone
.Cells(i, j).Interior.ColorIndex = 2
.Cells(i, j).Locked = True
.Cells(i, j).Value = ""
Next j
i = i + 1
Loop Until IsEmpty(.Cells(i, j))
End With
End Function
the function HowManyPeople is a basic row counting method. x is a public workbook variable given value in the HowManyPeople method. Week1 and Week2 are the technical names (not displayed name) of the worksheets
Solution
In the sub, change this :
ThisWorkbook.UpdateSheets (Week2)
to this
Call UpdateSheets(ThisWorkbook.Worksheets("Week2"))
Explanation of the problem
See similar question on SO
There is no UpdateSheets member of ThisWorkbook object.