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.
Related
The code below is taken from the link Similar values in range make it as a KEY and sum function, however, I have made small adjustments to it (adding more cells to be checked). What the code does, is to check if columns 4, 5, 8, 36 and 37 have similar values/text in their cells. If yes, then it looks in column 59 and uses the sum function to check if the values of the similar entries are less or higher than 100. If yes, then the cells in column 59 turn red, if not, they should remain white.
Example:
Column 4: Cell D5, D6 and D7 - all are P11
Column 5: Cell E5, E6 and E7 - all are P12
Column 8: Cell H5, H6 and H7 - all are P13
Column 36: Cell AJ5, AJ6 and AJ7 - all are P14
Column 37: Cell AK5, AK6 and AK7 - all are P15
Column 59: Cell BG5 = 40 and BG6 = 20 and BG7 = 30. Total value: 90 which does not equal 100. Henceforth, BG5, BG6 and BG7 must turn red. (the sum function works only when the other columns mentioned have similar value in their rows)
The code worked when it was checking only the columns 4, 5 and 8 and no error was received. However, after I added also the columns 36 and 37, the following error is received: Unable to get the interior property of the range class - Run time error 1004 and I don't know how to solve this.
Note: The columns 4, 5, 8, 36, 37 and 59 also have the conditional formatting formula isblank to turn the cells red if they are empty. The reason for that is because people need to know that those cells are mandatory to complete.
Thanks for your help and time!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, j As Long, sum1 As Long, k As Long, c(5000) As Long
Application.EnableEvents = False
Range("bg5:bg5000").Interior.Color = RGB(255, 255, 255)
For i = 5 To 4999
k = 0
For j = i + 1 To 5000
If Cells.Interior.Color <> RGB(255, 0, 0) Then
If Cells(i, 4) & Cells(i, 5) & Cells(i, 8) & Cells(i, 36) & Cells(i, 37) <> "" Then
If Cells(i, 4) = Cells(j, 4) And Cells(i, 5) = Cells(j, 5) And Cells(i, 8) = Cells(j, 8) And Cells(i, 36) = Cells(j, 36) And Cells(i, 37) = Cells(j, 37) Then
If k = 0 Then sum1 = Cells(i, 59): k = 1: c(k) = i
sum1 = sum1 + Cells(j, 59)
k = k + 1
c(k) = j
End If
End If
End If
Next j
If sum1 <> 100 Then
For j = 1 To k
Cells(c(j), 59).Interior.Color = RGB(255, 0, 0)
Next j
End If
Next i
Application.EnableEvents = True
End Sub
here a proposal to adapt the code. Note that the macro runs each time you enter a value in column 59 and that it executes the code insides the loop for about 2500000 times, this may take some time.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, j As Long, sum1 As Long, k As Long, c(5000) As Long
If Target.Column <> 59 Then Exit Sub
Application.EnableEvents = False
Range("bg5:bg5000").Interior.Color = RGB(255, 255, 255)
For i = 5 To 4999
k = 0
If Cells(i, 4) & Cells(i, 5) & Cells(i, 8) & Cells(i, 36) & Cells(i, 37) <> "" Then
If Cells(i, 59).Interior.Color <> RGB(255, 0, 0) Then
For j = i + 1 To 5000
If Cells(j, 59).Interior.Color <> RGB(255, 0, 0) Then
If Cells(j, 4) & Cells(j, 5) & Cells(j, 8) & Cells(j, 36) & Cells(j, 37) <> "" Then
If Cells(i, 4) = Cells(j, 4) And Cells(i, 5) = Cells(j, 5) And Cells(i, 8) = Cells(j, 8) And Cells(i, 36) = Cells(j, 36) And Cells(i, 37) = Cells(j, 37) Then
If k = 0 Then sum1 = Cells(i, 59): k = 1: c(k) = i
sum1 = sum1 + Cells(j, 59)
k = k + 1
c(k) = j
End If
End If
End If
Next j
If sum1 <> 100 Then
For j = 1 To k
Cells(c(j), 59).Interior.Color = RGB(255, 0, 0)
Next j
End If
End If
End If
Next i
Application.EnableEvents = True
End Sub
code adapted, if you want to link it to a button, add a button, right-click on the button and assign this macro (aargh) to it.
Sub aargh()
Dim i As Long, j As Long, sum1 As Long, k As Long, c(5000) As Long, fl(5000) As Boolean
Dim s1 As String, s2 As String
Range("bg5:bg5000").Interior.Color = RGB(255, 255, 255)
For i = 5 To 4999
k = 0
s1 = Cells(i, 4) & Cells(i, 5) & Cells(i, 8) & Cells(i, 36) & Cells(i, 37)
If s1 <> "" Then
If Not fl(i) Then
For j = i + 1 To 5000
If Not fl(j) Then
s2 = Cells(j, 4) & Cells(j, 5) & Cells(j, 8) & Cells(j, 36) & Cells(j, 37)
If s2 <> "" Then
If s1 = s2 Then
If k = 0 Then sum1 = Cells(i, 59): k = 1: c(k) = i: fl(i) = True
sum1 = sum1 + Cells(j, 59)
k = k + 1
c(k) = j
fl(j) = True
End If
End If
End If
Next j
If sum1 <> 100 Then
For j = 1 To k
Cells(c(j), 59).Interior.Color = RGB(255, 0, 0)
Next j
End If
End If
End If
Next i
End Sub
For the first time I've worked in Excel VBA to find rows in my dataset that contain the same adress as another entry in a cluster. These entries have to be merged and the row then is deleted. I've come up with the following, which works (As far as I can tell from the testing I did on small samples of the set):
Sub Merge_Orders()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim y As Long
Dim x As Long
Dim j As Long
Dim k As Long
For i = 2 To lastrow //for each row, starting below header row
j = 1
y = (Cells(i, 9)) //this is the clusternumber
Do While y = (Cells(i + j, 9)) //while the next row is in the same cluster
x = (Cells(i, 12)) //this is the adresscode
k = 1
Do While x = (Cells(i + k, 12)) //while the current adresscode is the same as the next, iterating until another adresscode is hit
Cells(i, 16) = Val(Cells(i, 16)) + Val(Cells(i + k, 16)) //update cell value
Cells(i, 18) = Cells(i, 18) + Cells(i + k, 18) //update cell value
Cells(i, 19) = Cells(i, 19) + Cells(i + k, 19) //update cell value
If Cells(i, 20) > Cells(i + k, 20) Then
Cells(i, 20) = Cells(i + k, 20) //update cell value
End If
If Cells(i, 21) > Cells(i + k, 21) Then
Cells(i, 21) = Cells(i + k, 21) //update cell value
End If
Cells(i, 22) = Cells(i, 22) + Cells(i + k, 22) //update cell value
Cells(i, 23) = Cells(i, 23) + Cells(i + k, 23) //update cell value
Rows(i + 1).EntireRow.Delete //Delete the row from which data was pulled
k = k + 1
Loop
j = j + 1
Loop
Next i
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
The problem I'm facing is time. Testing this on a small sample of ~50 rows took over 5 minutes. My entries total over 100K rows. It's been running for over a day with no end in sight. Is there a way to optimize this so I don't have to wait until I'm grey?
Kind regards,
Rob
Two things as I mentioned in the comments:
1) Remove k (and the entire k=k+1 line); replace with j. Also replace your Rows(i + 1).EntireRow.Delete with Rows(i + j).EntireRow.Delete.
2) Since you are deleting rows, lastrow is actually blank by the time you get there. Instead of i=2 to lastrow, make it do while Cells(i,12)<>"" or something. This is causing it to loop over a bunch of rows that are empty.
Also, you can do these type of rollups much easier with a PivotTable, or, as mentioned in the comments, with an SQL GROUP BY.
When I run the program, nothing happens. I think it's because I am not using the right variable types or I am not doing variable and value assignment properly.
This is what I want the code to do:
For every cell from row 80, column 6 to row 90, column 6, I want j to be the INTEGER specified in that cell. For every column from 10 to 100, if the DATE in Cells(i,2) is the same as the DATE in Cells(1,k), then I want to set Cells(j, k) as the INTEGER found in Cells(j, 6).
Please help me correct this code.
Sub TestSub()
Dim i As Integer, i2 As Integer, i3 As Integer
Dim j As Integer, j2 As Integer, j3 As Integer
Dim k As Integer, k2 As Integer, k3 As Integer
For i = 81 To 95
j = Cells(i, 6) 'j becomes the row # of the equipment
For k = 8 To k = 115
If Cells(i, 2) = Cells(1, k) Then Cells(j, k) = Cells(j, 6) 'Cells(i,2)->NEXT PM DATE Cells(1,k)->CALENDER DATE (MM/1/YY)
Next k
Next i
For i2 = 97 To 105
j2 = Cells(i2, 6)
For k2 = 8 To k2 = 115
If Cells(i2, 2) = Cells(1, k2) Then Cells(j2 + 1, k2) = Cells(j2 + 1, 6)
Next k2
Next i2
For i3 = 107 To 121
j3 = Cells(i3, 6)
For k3 = 8 To k3 = 115
If Cells(i3, k3) = Cells(j3, 6) Then Cells(j3 + 2, k3) = Cells(j3 + 2, 6)
Next k3
Next i3
End Sub
Have to post a second answer as the asker changed entirely the code:
These lines will never work
For k = 8 To k = 115
For k2 = 8 To k2 = 115
For k3 = 8 To k3 = 115
Change to the correct format
For k = 8 To 115
For k2 = 8 To 115
For k3 = 8 To 115
Then try
The problem is you got confused because you used single-letter variable names and made a mistake in your code that is not easily identifiable. To correct the error, change this line:
If Cells(i, 2) = Cells(1, k) Then Cells(j, k) = Cells(j, 6)
To be this instead:
If Cells(i, 2) = Cells(1, k) Then Cells(j, k) = Cells(i, 6)
Notice the only difference is that instead of setting it to Cells(j, 6) it needs to be set to Cells(i, 6). This is a common mistake for new programmers, and is the exact reason that using descriptive variable names is good practice. It will prevent simple errors like this.
This is what your code is doing:
It compares the dates for each cell in range B80:B90 (rows 80 to 90) with the dates of cells in range J1:CV1 (columns 10 to 100)
If the dates compared are equal then it takes the value in the same row and column 6 (F). This value is then used to reference a row number and places that row number in the column that contains the same date.
The program is validating the dates in range B80:B90 with the dates in range J1:CV1 and for those found equal is updating the corresponding cell in the row determined by the corresponding value in the range F80:F90.
Let’s look at the following sample case, where the date in cell B80 equals the date in cell J1 and the value in cell F80 is 97.
Then the program will enter the value of cell F97 in cell J97
Dim i As Integer, j As Integer, k As Integer
For i = 80 To 90
If i = 89 Then Stop
j = Cells(i, 6)
For k = 10 To 100
'as per the sample case
'i = 80 ; j = 97 and k = 10
'date in cell(B80) = date in cell(J1)
'If Cells(i, 2) = Cells(1, k) Then Cells(j, k) = Cells(j, 6)
'then J97 = F97
'Replaced with:
If Cells(i, 2) = Cells(1, k) Then Cells(j, 6) = Cells(i, 6)
Next k: Next
Therefore, if it seems that the program is doing nothing and could not see any result is either because there are no equal dates in the ranges compared or because results are expected to be shown in the range J80:CV90 but the values in range F80:F90 are determining a different output range (i.e. the values in range F80:F90 are lower than 80 or higher than 90.
I asked for the values in range F80:F90 to be provided to validate the above.
So if the objective is:
If the dates are equal, then it takes the value in the same row and column 6 (F) and inserts that value into cells(j, 6)
Then replaced line
If Cells(i, 2) = Cells(1, k) Then Cells(j, k) = Cells(j, 6)
with line
If Cells(i, 2) = Cells(1, k) Then Cells(j, 6) = Cells(i, 6)
The value of j is the value in cell(i,6) as determined by the line:
j = Cells(i, 6)
Basically if the date in cell B80 is found in Range J1:CV1 then enters 73, value in cell F80 or Cell(i,6), into cell F73 or Cell(j,6).
I am new in and is trying to give an automated ID in which i used the following code:
y = 0
If txtdsgnation = "Plumbing" Then
x = "P"
Do Until Cells(i, 3) = ""
If Cells(i, 3) = "Plumbing" Then
y = y + 1
End If
i = i + 1
Loop
End If
If txtdsgnation = "Electricity" Then
x = "E"
Do Until Cells(i, 3) = ""
If Cells(i, 3) = "Electricity" Then
y = y + 1
End If
i = i + 1
Loop
End If
If txtdsgnation = "Fittings" Then
x = "F"
Do Until Cells(i, 3) = ""
If Cells(i, 3) = "Fittings" Then
y = y + 1
End If
i = i + 1
Loop
End If
If txtdsgnation = "Lift maintenance" Then
x = "L"
Do Until Cells(i, 3) = ""
If Cells(i, 3) = "Lift maintenance" Then
y = y + 1
End If
i = i + 1
Loop
End If
z = 100 + y
txtID = x + "-" + z
The thing i am trying to do is that if i add a new employee, for example a plumber and I already have 2 plumbers txtID will automatically become "P-102"
Thanks in advance
In the loop, the y is always getting initialized with 0. So, y has no chance to become more than 1. Please try to put the y out of the loop.
I am using a barcode scanner to do inventory with large quantities and I want to enter the data into excel. I can change the way that the scanner behaves after each scan to do things like tab, return, etc. but my big problem is that in order to efficiently provide the quantity I have to scan the item code (7 digits) and then scan the quantities from 0 to 9 in succession. Such that 548 is really 5, 4, 8 and when using excel it puts each number into a new cell. What I would like to do, but don't have the VBA chops to do it is to have excel check to see if the length is 7 digits or one digit. For each one digit number it should move the number to the next cell in the same row as the previous 7 digit number such that each successive one digit number is combined as if excel were concatenating the cells. Then it should delete the single digits in the original column and have the next row start with the 7 digit barcode number.
I hope this makes sense.
Example:
7777777
3
4
5
7777778
4
5
6
7777779
7
8
9
Should become:
| 7777777 | 345 |
| 7777778 | 456 |
| 7777779 | 789 |
Thanks!!
I set up my worksheet like this:
then ran the below code
Sub Digits()
Application.ScreenUpdating = False
Dim i&, r As Range, j&
With Columns("B:B")
.ClearContents
.NumberFormat = "#"
End With
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Set r = Cells(i, 1)
If Len(r) = 7 Then
j = 1
Do Until ((Len(r.Offset(j, 0).Text) = 7) Or (IsEmpty(r.Offset(j, 0))))
Cells(i, 2) = CStr(Cells(i, 2).Value) & CStr(r.Offset(j, 0))
j = j + 1
Loop
End If
Set r = Nothing
Next
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Len(Cells(i, 1)) < 7 Then Rows(i & ":" & i).Delete
Next i
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
and the results Ive got:
This is what I did with what you started but I think your newer solution will work better. Thank you so much mehow!
Sub Digits()
Application.ScreenUpdating = False
Dim i, arr, r As Range
Dim a, b, c, d, e
Dim y
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Set r = Cells(i, 1)
Set a = Cells(i + 1, 1)
Set b = Cells(i + 2, 1)
Set c = Cells(i + 3, 1)
Set d = Cells(i + 4, 1)
Set e = Cells(i + 5, 1)
If Len(a) = 7 Then
y = 0
ElseIf Len(b) = 7 Then
y = 1
ElseIf Len(c) = 7 Then
y = 2
ElseIf Len(d) = 7 Then
y = 3
ElseIf Len(e) = 7 Then
y = 4
Else:
y = 0
End If
If Len(r) = 7 Then
arr = Range("A" & i & ":A" & i + y).Value
Range("B" & i & ":F" & i) = WorksheetFunction.Transpose(arr)
End If
Next
Cells.Replace "#N/A", "", xlWhole
Application.ScreenUpdating = True
End Sub