The below is a snippet of the code I'm using. I'm having a problem with how I need to name j. I need it to be 3,4,5,6 for the first tab_name and then 7,8,9,10 for the next and 11,12,13,14 for the one after that etc.
Can I improve the way I've attempted below?
tab_names = Array("11EB", "11WB", "12EB", "12WB", "13EB", "13WB", "14EB")
Location = Array(3, 7, 11)
For Each indiv_tab In tab_names
For Each j In Location
For i = 9 To 24
Sheets("Front Page").Cells(2, 2) = Cells(i, 1)
Cells(i, j) = Sheets(indiv_tab).Cells(2993, 9)
Cells(i, j + 1) = Sheets(indiv_tab).Cells(2993, 22)
Cells(i, j + 2) = Sheets(indiv_tab).Cells(2993, 35)
Cells(i, j + 3) = Sheets(indiv_tab).Cells(2993, 48)
Next i
Next j
Next
EDIT
I'm now using the below code, however, I need it go Next tab_name and Next j at the same time. Is there anyway to do this?
tab_names = Array("11EB", "11WB", "12EB", "12WB", "13EB", "13WB", "14EB", "14WB", "15NB", "15SB", "16NB", "16SB", "17EB", "17WB", "18EB", "18WB", "19NB", "19SB", "20NB", "20SB", "21NB", "21SB", "22NB", "22SB", "23NB", "23SB", "24NB", "24SB", "25NB", "25SB", "26NB", "26SB", "27EB", "27WB", "28EB", "28WB", "29EB", "29WB", "30EB", "30WB", "31NB", "31SB", "32NB", "32SB", "33EB", "33WB", "34EB", "34WB", "35NB", "35SB", "36NB", "36SB", "37EB", "37WB", "38NB", "38SB", "39NB", "39SB", "40EB", "40WB", "41EB", "41WB", "A12NB", "A12SB", "M11NB", "M11SB", "M25NB", "M25SB", "A120EB", "A120WB", "A120AEB", "A120AWB")
For i = 9 To 24
For Each indiv_tab In tab_names
For j = 3 To 291 Step 4
Sheets("Front Page").Cells(2, 2) = Cells(i, 1)
Cells(i, j) = Sheets(indiv_tab).Cells(2993, 9)
Cells(i, j + 1) = Sheets(indiv_tab).Cells(2993, 22)
Cells(i, j + 2) = Sheets(indiv_tab).Cells(2993, 35)
Cells(i, j + 3) = Sheets(indiv_tab).Cells(2993, 48)
Next j
Next
Next i
Thanks for any help.
Do you mean you want j to iterate through 3, 4, 5, 6 on the first tab, then 7, 8, 9, 10 on the second etc...?
If so, the below should work. Start with location as I've specified (declare as a new variable if you use it elsewhere), then manually adjust it each time.
tab_names = Array("11EB", "11WB", "12EB", "12WB", "13EB", "13WB", "14EB")
Location = Array(3, 4, 5, 6) '##changed this
For Each indiv_tab In tab_names
For Each j In Location
For i = 9 To 10
Sheets("Front Page").Cells(2, 2) = Cells(i, 1)
Cells(i, j) = Sheets(indiv_tab).Cells(2993, 9)
Cells(i, j + 1) = Sheets(indiv_tab).Cells(2993, 22)
Cells(i, j + 2) = Sheets(indiv_tab).Cells(2993, 35)
Cells(i, j + 3) = Sheets(indiv_tab).Cells(2993, 48)
Next i
Next j
'adjust values on each loop
For i = 0 To UBound(Location, 1)
Location(i) = Location(i) + 4
Next i
Next
Related
I have this bit of my code which takes like 90 % of the runtime.
There are about 8000 rows and information are stored in column A. This bit of code is splitting this information in the other columns.
It takes approximately 15 mins to run ( :O ).
Any suggestions on how to improve the performance ?
For i = 2 To Row_Number ' Loop for each row
If InStr(Cells(i, 1), "//") = 0 Then ' This means that if // appears somewhere in the text we delete all the rows (including this one) (see Else :) and stop the loop
j = 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
LongVIN = Mid(Cells(i, 1), 1, j - 1)
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
Cells(i, 3) = Mid(Cells(i, 1), k + 1, j - k - 1) ' Model
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
Cells(i, 4) = Mid(Cells(i, 1), k + 1, j - k - 1) ' Dealer
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
Cells(i, 6) = Mid(Cells(i, 1), k + 1, j - k - 1) ' Region
k = j
j = j + 1
Do Until Mid(Cells(i, 1), j, 1) = ";"
j = j + 1
Loop
Cells(i, 7) = CDate(Mid(Cells(i, 1), k + 1, j - k - 1)) ' Retail Date
k = j
Cells(i, 5) = Mid(Cells(i, 1), k + 1, Len(Cells(i, 1)) - k) '(Len - (k+1) +1) Dealer Name
Cells(i, 1) = Mid(LongVIN, 1, 10)
Cells(i, 2) = Mid(LongVIN, 11, 7)
Else:
Range("A" & i & ":A" & Row_Number).Delete 'ClearContents
Exit For
End If
Next i
You should see a significant boost in performance by storing the data in an array, operating on the array, and storing the data back into the spreadsheet.
Something like:
Dim data As Variant
Dim result As Variant
data = Range(Cells(2, 1), Cells(Row_Number, 1))
Redim result (1 To Row_Number, 1 To 7) As Variant
Now instead of reading from Cells(i, 1), you read from data(i, 1) and instead of writing to Cells(i, n) you write to result(i, n).
And at the end of your code:
Range(Cells(2, 1), Cells(Row_Number, 7)) = result
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.
I am fairly inexperienced with VBA, and I can't figure out how to make this loop. I set up 4 separate statements and it works this way, but I want to make this one statement.
i = 1
Do Until i > combos
Range(Cells(i, 10), Cells(i + Defrepeat - 1, 10)) = Range(Cells(3, 4), Cells(3, 4))
i = i + TErepeat
Loop
w = 4
Do Until w > combos
Range(Cells(w, 10), Cells(w + Defrepeat - 1, 10)) = Range(Cells(4, 4), Cells(4, 4))
w = w + TErepeat
Loop
p = 7
Do Until p > combos
Range(Cells(p, 10), Cells(p + Defrepeat - 1, 10)) = Range(Cells(5, 4), Cells(5, 4))
p = p + TErepeat
Loop
k = 10
Do Until k > combos
Range(Cells(k, 10), Cells(k + Defrepeat - 1, 10)) = Range(Cells(6, 4), Cells(6, 4))
k = k + TErepeat
Loop
Dim c As Range, i As Long, n As Long
Set c = Cells(3, 4)
For n = 1 To 10 Step 3
i = n
Do Until i > combos
Range(Cells(i, 10), Cells(i + Defrepeat - 1, 10)) = c.Value
i = i + TErepeat
Loop
Set c = c.Offset(1, 0)
Next n
I've got a listbox of 11 columns. When I try to add data to one of the columns, I get an error.
ListBox1.Column(10, j) = shtG.Cells(k, 13)
I don't understand why this happens, the listbox on the userform has a ColumnCount of 11.
The error I'm getting:
"Run-time error 380: Unable to set Column property. Invalid property value."
The value of the selected cell is "Group 16".
More info:
Code:
'adding this doesn't help
ListBox1.Clear
ListBox1.ColumnCount = 20
While shtG.Cells(k, 1) <> ""
If 'some long working condition Then
frmTP.ListBox1.AddItem (shtG.Cells(k, kolID))
frmTP.ListBox1.Column(1, j) = shtG.Cells(k, kolVnm) & strSpace & shtG.Cells(k, kolTV) & strSpace & shtG.Cells(k, kolAnm)
frmTP.ListBox1.Column(2, j) = shtG.Cells(k, 5)
frmTP.ListBox1.Column(3, j) = shtG.Cells(k, 6)
frmTP.ListBox1.Column(4, j) = shtG.Cells(k, 7)
frmTP.ListBox1.Column(5, j) = shtG.Cells(k, 8)
frmTP.ListBox1.Column(6, j) = shtG.Cells(k, 9)
frmTP.ListBox1.Column(7, j) = shtG.Cells(k, 10)
frmTP.ListBox1.Column(8, j) = shtG.Cells(k, 11)
frmTP.ListBox1.Column(9, j) = shtG.Cells(k, 12)
frmTP.ListBox1.Column(10, j) = shtG.Cells(k, 13)
j = j + 1
End If
k = k + 1
Wend
This is the sort of thing I mean (you could improve performance by loading the sheet data into an array to begin and processing that, and not resizing the array so often, but it would distract from the key idea here!):
Dim vData()
j = 0
While shtG.Cells(k, 1) <> ""
If 'some long working condition Then
ReDim Preserve vData(0 To 10, 0 To j)
vData(0, j) = shtG.Cells(k, kolID).Value
vData(1, j) = shtG.Cells(k, kolVnm) & strSpace & shtG.Cells(k, kolTV) & strSpace & shtG.Cells(k, kolAnm)
vData(2, j) = shtG.Cells(k, 5)
vData(3, j) = shtG.Cells(k, 6)
vData(4, j) = shtG.Cells(k, 7)
vData(5, j) = shtG.Cells(k, 8)
vData(6, j) = shtG.Cells(k, 9)
vData(7, j) = shtG.Cells(k, 10)
vData(8, j) = shtG.Cells(k, 11)
vData(9, j) = shtG.Cells(k, 12)
vData(10, j) = shtG.Cells(k, 13)
j = j + 1
End If
Wend
frmTP.ListBox1.Column = vData
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.