Is there a way to count unempty cells in excel vba - vba

I need help with the below. Everything works in the code just fine except this part
For j = i + 1 To i + 4
Cells(j, 9) = Cells(j, 9) + Abs(Cells(i + 1, 13)) / 4
In the workbook the data looks like this
1
2
3
4
5
6
7
8
In the loop, j essentially needs to be a count of the separated cells.
For now I dont know how to do that, so Abs(Cells(i + 1, 13)) is just divided by 4 and not by j.
I need j=3 for 6,7,8 and then j=5 for 1,2,3,4,5.
To explain a bit further, if the data looks like this
13
2
5
6
5
4
54
4
3
6
Then j=6 for
5
4
54
4
3
6
and j=4 for
13
2
5
6
Code is shown below. I just put 10000=i because it is a large data set
Sub check1()
Dim i As Integer
Dim j As Integer
i = 10000
While i > 0
If Cells(i, 9) > 0 Then Cells(i, 12) = Cells(i + 1, 12) + Cells(i, 9)
If Cells(i, 12) = 0 Then Cells(i + 1, 13) = Cells(i + 1, 12) - Cells(i, 7) * Cells(i, 6)
If Cells(i + 1, 13) > 1 Or Cells(i + 1, 13) < -1 Then Cells(i + 1, 14) = "PLEASE CHECK VALUES"
If Cells(i + 1, 13) > 1 Or Cells(i + 1, 13) < -1 Then
For j = i + 1 To i + 4
Cells(j, 9) = Cells(j, 9) + Abs(Cells(i + 1, 13)) / 4
Next j
End If
i = i - 1
Wend
End Sub

Related

Object Defined error! Am i missing something?

I am relatively new to vba but i've been stuck on this code for hours. Unable to figure out whats wrong with it. I get a debugging error at
" If Cells(Counter, 1).Value <> Empty Then Flag = False"
It says Application defined or object defined error. I don't see what the problem lies in though. Any help would be much appreciated.
Sub Macro1()
ActiveSheet.Unprotect
Workbooks("Cerebus.xlsm").Sheets("Tree").Activate
N = ActiveSheet.Cells(3, 2).Value
Flag = True
Counter = 11
# Counter loops
Do While (Flag = True)
Counter = Counter + 1
If Cells(Counter, 1).Value <> Empty Then Flag = False
Loop
# adjusting for white space
For i = 10 To (Counter - 11) + Counter + 1
For j = 1 To (Counter - 11) / 2 + 1
Cells (i,j).Select
Selection.Clear
Next
Next
For i = 0 To N
Cells(10, N + 1).Value = N
Cells(11 + i * 4, N + 1).Value = 5
Cells(11 + i * 4, N + 1).Interior.ColorIndex = 6
Cells(11 + i * 4 + 1, N + 1).Value = 5
Cells(11 + i * 4 + 1, N + 1).Interior.ColorIndex = 12
Next
For j = 1 To N
For i = 0 To N - j
Cells(10, N - j + 1).Value = N - j
Cells(11 + 2 * j + i * 4, N - j + 1).Value = 6
Cells(11 + 2 * j + i * 4, N - j + 1).Interior.ColorIndex = 6
Cells(11 + 2 * j + i * 4 + 1, N - j + 1).Value = 6
Cells(11 + 2 * j + i * 4 + 1, N - j + 1).Interior.ColorIndex = 12
Next
Next
End Sub
If the error is 1004 and occurs at
If Cells(Counter, 1).Value <> Empty Then Flag = False
the only reason I can imagine is that the Counter went beyond the maximum allowed Rows.Count (i.e. 1048576). That would mean you don't have any non-empty cells below row 11 in your sheet and hence Flag was never reset to False.
It is quite possible that the ActiveSheet isn't the one you actually think it is. Best solution is to drop the use of ActiveSheet and replace it by an explicit worksheet.

Consolidating values on an unevenly spaced spreadsheet Excel VBA

Writing rudimentary VBA to populate a 2 dimensional array filled with two sums one consisting of the odd columns the other is the sum of the even columns, totaled over a variable amount of rows stored in another array. the two dimensional array then prints on a seperate worksheet. I wrote code which succesfully completed this task on two other worksheets in the same file with slightly different sized arrays, but it populates the destination range with zeros when adjusted for the new input and output.
code in question:
Sub dad()
Dim i As Integer, j As Integer, units As Double, value As Double, mr(1 To 655, 1 To 3) As Double, u As Integer, here As Range
Dim thisone As String, there As Range
thisone = Worksheets("MB52 for 1010").Cells(1, 1).Address
Set here = Range(thisone)
MsgBox (here(1, 1).Address)
thisone = Worksheets("1010totals").Cells(1, 1).Address
Set there = Range(thisone)
MsgBox (there(1, 1).Address)
For i = 1 To 655
mr(i, 1) = Worksheets("1010totals").Cells(i + 1, 4).value
Next i
MsgBox ("array made")
i = 1
u = 1
MsgBox (i & " " & u)
For i = 1 To 655
For j = 1 To mr(i, 1)
u = u + 1
units = here(u, 6) + here(u, 9) + here(u, 11).value + here(u, 13) + here(u, 15) + here(u, 17)
value = here(u, 8) + here(u, 10) + here(u, 12).value + here(u, 14) + here(u, 16) + here(u, 18)
Next j
mr(i, 2) = units
mr(i, 3) = value
Next i
For i = 1 To 655
For j = 2 To 3
Worksheets("1010totals").Cells(i + 1, j).value = mr(i, j)
Next j
Next i
End Sub
Original code that works on the other worksheets:
Sub ded()
Dim i As Integer, j As Integer, units As Double, value As Double, n As Integer, mr(1 To 756, 1 To 3) As Double, u As Integer, here As Range
Dim thisone As String, there As Range
thisone = Worksheets("MB52 for 1030").Cells(1, 1).Address
Set here = Range(thisone)
MsgBox (here(1, 1).Address)
thisone = Worksheets("1030totals").Cells(1, 1).Address
Set there = Range(thisone)
MsgBox (there(1, 1).Address)
For i = 1 To 756
mr(i, 1) = Worksheets("1030totals").Cells(i + 1, 4).value
Next i
MsgBox ("array made")
i = 1
u = 1
MsgBox (i & " " & u)
For i = 1 To 756
For j = 1 To mr(i, 1)
u = u + 1
units = here(u, 6) + here(u, 9) + here(u, 11).value + here(u, 13) + here(u, 15) + here(u, 17)
value = here(u, 8) + here(u, 10) + here(u, 12).value + here(u, 14) + here(u, 16) + here(u, 18)
Next j
mr(i, 2) = units
mr(i, 3) = value
Next i
For i = 1 To 756
For j = 2 To 3
Worksheets("1030totals").Cells(i + 1, j).value = mr(i, j)
Next j
Next i
End Sub

Speeding up VBA code

firstly I apologise for posting such a large section of vba, however this is just a snippet! I've used my macro on a test section of data and it works fine. However, whilst using it on the full extent of the data (3447 rows x 5400 columns) it has run for 3 days without working. I then have run it line by line and it appears to be this section that is causing the problem. It is running off Excel 2013 64-bit and is using 7.5GB of memory currently but I believe this increases to full capacity of ~16GB later in the macro.
Any suggestions how to improve any of the code would be most appreciated.
Application.Calculation = xlManual
For j = 0 To NumberDays - 1
For h = 5 To NumberLinks + 4 'Columns
For i = 5 + j * 14 To 16 + j * 14 'Rows
If Cells(i, h) = 0 Then 'Found a 0 to be filled in
'Stop
If i = 5 + j * 14 And Cells(i - 1, h) = 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 Then _
'If hours starting 6 to 9 are zero use profile
Range(Cells(i, h), Cells(i + 2, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
Cells(i + 1, h) = Worksheets("Zeroes").Cells(MedianLook + 1, h)
Cells(i + 2, h) = Worksheets("Zeroes").Cells(MedianLook + 2, h)
End If 'If3
Next MedianLook
GoTo ProfileWasRequired:
End If
If i = 14 + j * 14 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 Then _
'If hours starting 16 to 19 are zero use profile
Range(Cells(i, h), Cells(i + 2, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
Cells(i + 1, h) = Worksheets("Zeroes").Cells(MedianLook + 1, h)
Cells(i + 2, h) = Worksheets("Zeroes").Cells(MedianLook + 2, h)
End If
Next MedianLook
GoTo ProfileWasRequired:
End If
If i = 5 + j * 14 And Cells(i - 1, h) = 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) <> 0 Then _
'Hours 6 to 8 are zero, fill hours 7 and 8 with hour 9 data
Cells(i + 1, h) = Cells(i + 2, h)
Cells(i, h) = Cells(i + 2, h)
End If
If i = 5 + j * 14 And Cells(i - 1, h) = 0 And Cells(i + 1, h) <> 0 Then _
'Hours 6 and 7 are zero, fill hour 7 with hour 8
Cells(i, h) = Cells(i + 1, h)
End If
If i = 15 + j * 14 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i - 1, h) <> 0 Then _
'If hours starting 17 to 19 are zero, fill hours 17 and 18 with hour 16 data
Cells(i + 1, h) = Cells(i - 1, h)
Cells(i, h) = Cells(i - 1, h)
End If
If i = 16 + j * 14 And Cells(i + 1, h) = 0 And Cells(i - 1, h) <> 0 Then _
'If hours 18 to 19 are zero, fill hour 18 with hour 17 data
Cells(i, h) = Cells(i - 1, h)
End If
If Cells(i - 1, h) <> 0 And Cells(i + 1, h) <> 0 Then _
'One hour is zero, fill with average of preceding and subsequent hours' data
Cells(i, h) = (Cells(i - 1, h) + Cells(i + 1, h)) / 2
End If
If i < 16 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 And Cells(i + 4, h) = 0 Then _
'Error if 5 sequential hours are zero
Range(Cells(i, h), Cells(i + 4, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
LinestoFillDown = 1
Do While Cells(i + LinestoFillDown, 4) < 19 'only do up to hour starting 18
Cells(i + LinestoFillDown, h) = Worksheets("Zeroes").Cells(MedianLook + LinestoFillDown, h)
LinestoFillDown = LinestoFillDown + 1
Loop
End If
Next MedianLook
GoTo ProfileWasRequired:
End If
If i < 16 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 And Cells(i + 4, h) = 0 And Cells(i + 4, h) = 0 Then _
'Error if 6 sequential hours are zero
Range(Cells(i, h), Cells(i + 5, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
LinestoFillDown = 1
Do While Cells(i + LinestoFillDown, 4) < 19 'only do up to hour starting 18
Cells(i + LinestoFillDown, h) = Worksheets("Zeroes").Cells(MedianLook + LinestoFillDown, h)
'
LinestoFillDown = LinestoFillDown + 1
Loop
End If
Next MedianLook
GoTo Error:
End If
If i < 14 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 And Cells(i + 4, h) <> 0 Then _
'if four sequential hour are zero fill first and last from preceding and subsequent hours and middle two by average of those
Cells(i, h) = Cells(i - 1, h)
Cells(i + 3, h) = Cells(i + 4, h)
Cells(i + 1, h) = (Cells(i - 1, h) + Cells(i + 4, h)) / 2
Cells(i + 2, h) = (Cells(i - 1, h) + Cells(i + 4, h)) / 2
End If
If i < 15 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) <> 0 Then _
'If three sequential hours are zero fill first and last from preceding and subsequent hours and middle one average of those
Cells(i, h) = Cells(i - 1, h)
Cells(i + 2, h) = Cells(i + 3, h)
Cells(i + 1, h) = (Cells(i - 1, h) + Cells(i + 3, h)) / 2
End If
If i < 16 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) <> 0 Then _
'Except for last hour, fill two zero cells from preceding and subsequent ones
Cells(i, h) = Cells(i - 1, h)
Cells(i + 1, h) = Cells(i + 2, h)
End If
End If '(If 1)
ProfileWasRequired:
Next i
Next h
Next j
Application.Calculation = xlAutomatic
I would suggest storing the range values before iterating through them anytime you can. Anytime you have to access values that you can see on the screen, it will be slower. You will not be able to update the borders or background this way though.
Here is an example using the "Cells" like you have above. On my machine it requires almost 2 seconds to loop through 65535 cells.
Sub UsingCells()
Dim tmr As Single
tmr = Timer
Dim i As Long
For i = 1 To 65535
Cells(i, 1) = Cells(i, 1)
Next i
Debug.Print Timer - tmr
End Sub
Here is an example using the the range values after being stored in memory. On my machine it requires about 30 milliseconds to loop through the same 65535 cells.
Sub UsingStoredValues()
Dim tmr As Single
tmr = Timer
Dim vals As Variant
vals = Range("A1:A65535").Value2
Dim i As Long
For i = 1 To 65535
vals(i, 1) = vals(i, 1)
Next i
Range("A1:A65535").Value2 = vals
Debug.Print Timer - tmr
End Sub

Finding the latest in grouping

I have several hundred cells. I want to find the latest in the grouping. For instance i have the following data:
233400-003-02
233400-002-03
233400-002-02
233400-002-01
233400-001-04
233400-001-03
233400-001-02
233400-001-01
The last number defines the revision. I want to keep only the greatest number or the latest revision. so far I have
For j = 9 To i Step 1
Dim Idstring As String
If Len(Cells(j, 1)) = 13 Then
Idstring = Left(Cells(j, 1), 10)
Cells(j, 5) = Idstring
ElseIf Len(Cells(j, 1)) = 16 Then
Idstring = Left(Cells(j, 1), 10)
Cells(j, 5) = Idstring
ElseIf Len(Cells(j, 1)) = 17 Then
Idstring = Left(Cells(j, 1), 14)
Cells(j, 5) = Idstring
ElseIf Len(Cells(j, 1)) = 20 Then
Idstring = Left(Cells(j, 1), 14)
Cells(j, 5) = Idstring
End If
If Cells(j, 5) = Cells(j - 1, 5) Then
If Len(Cells(j, 1)) = 16 Then
Cells(j, 5).EntireRow.Delete
ElseIf Len(Cells(j, 1)) = 20 Then
Cells(j, 5).EntireRow.Delete
ElseIf Right(Cells(j, 1), 1) < Right(Cells(j + 1, 1), 1) Then
Cells(j, 5).EntireRow.Delete
ElseIf Right(Cells(j, 1), 1) > Right(Cells(j + 1, 1), 1) Then
Cells(j + 1, 5).EntireRow.Delete
j = j + 1
End If
End If
Next j
What am I doing wrong? Thank you for your help.
I think your comparing to Cells(j-1) before you fill Cells(j-1). But if I'm wrong about that, you need to loop backward through the range when you delete rows or Excel loses track of where you are.
Public Sub DeleteAllButLatest()
Dim i As Long
For i = 9 To 3 Step -1
If Base(Cells(i, 1).Value) = Base(Cells(i - 1, 1).Value) Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End Sub
Public Function Base(ByVal sCode As String) As String
Select Case Len(sCode)
Case 13, 17
Base = Left(sCode, Len(sCode) - 3)
Case 16, 20
Base = Left(sCode, Len(sCode) - 6)
End Select
End Function
Based on your sample data in A2:A9. Only need to go to Row 3 because Row 2 will have to be good so no need to check it. I made a function to return the "base" of each number so you can compare the base of the current cell to the cell above it. If they're the same, delete. If not, assume it's the latest.

Creating a Count if in VBA

I wrote a quick script to sum everything in column E if everything is equal in column A, C, and D. I am getting an error and the actual sum function isn't working. Do you know why this would be happeing?
For i = 36 To 714 Step 1
Count = 0
If Cells(i, 7) <> 1 Then
x = i + 1
Do While x <> 714
Count = Cells(i, 5)
If Cells(i, 1) = Cells(x, 1) And Cells(i, 3) = Cells(x, 3) And Cells(i, 4) = Cells(x, 4) Then
Cells(x, 7) = 1
Count = Count + Cells(x, 5)
End If
x = x + 1
Loop
Cells(i, 6) = Count
End If
Next
As long as i reaches 714, x becomes 715 which is not equal to 714 and then do while loop stuck with eternal x. Use <= instead.

Resources