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
Related
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 need to copy a lot of rows. I tried to do something.copy something else.paste but it's extremely slow
I tried to do
Range(..).value(formula) = Range(..).value(formula) but its not so good because i have a date there that turn to ######
I need a faster way to do this copy/paste
This is my code:
Function Last_Col(k As Long) As Long
Last_Col = Cells(k, Columns.Count).End(xlToLeft).Column
End Function
Function Last_Col_Doc() As Long
Last_Col_Doc = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Column
End Function
Function Is_Grouped(i As Long) As Boolean
Is_Grouped = (Cells(i, 2).Rows.OutlineLevel > 1)
End Function
Function Is_Bold(i As Long) As Boolean
Is_Bold = Cells(i, 2).Font.Bold
End Function
Function Print_NA(i As Long, k As Long) As Boolean
Range(Cells(i, 21), Cells(i, 21 + k - 2)).Value = "NA"
End Function
Function Last_Row() As Long
Last_Row = Cells(Rows.Count, "B").End(xlUp).Row
End Function
Sub EditParanoia()
Dim FrstBlkRow As Long
Dim flag As Boolean
Dim i As Long
Dim HeadLen As Long
FrstBlkRow = Last_Col(1) + 1
If FrstBlkRow < 25 Then 'first edit
flag = True
i = 2
Do While flag
If Is_Bold(i) Then
flag = False
Else
i = i + 1
End If
Loop
HeadLen = Last_Col(i)
Range(Cells(i, 2), Cells(i, HeadLen)).Copy
Range(Cells(1, FrstBlkRow), Cells(1, FrstBlkRow + HeadLen - 2)).PasteSpecial
Else
FrstBlkRow = 21
HeadLen = 10
End If
Dim j As Long
For i = 2 To Last_Row Step 1
If Not Is_Grouped(i) And Not Is_Grouped(i + 1) And Cells(i, FrstBlkRow + 1).Value = vbNullString Then
'if not part of group
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 2)).Value = "NA"
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) And Is_Grouped(i + 2) And Not Is_Grouped(i + 3) Then
'if Part of group of 1 val
Range(Cells(i + 2, 2), Cells(i + 2, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 3)).PasteSpecial
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) Then
'if part of group of more then one val
j = 1
Do Until Is_Grouped(i + j) And Not Is_Grouped(i + j + 1)
'j will get the langth of any group
j = j + 1
Loop
'past the relevant cell in the right place
Range(Cells(i + 2, 2), Cells(i + 2 + j - 1 - 1, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i + j - 1 - 1, FrstBlkRow + HeadLen - 3)).PasteSpecial
'past the head respectively
Range(Cells(i, 1), Cells(i, 20)).Copy
Range(Cells(i + 1, 1), Cells(i + j - 2, FrstBlkRow - 1)).PasteSpecial
End If
Next
End Sub
When you say you've tried "Range(..).value(formula) = Range(..).value(formula)", what do you mean? You should be able to set two ranges equal to eachother:
Say A1:A10 has "Batman, 10-01-2015" and you want to copy that range to B1:B10, Range("B1:B10").Value = Range("A1:A10").Value. You can't do that? I tried it with dates, and it set the B range values to dates, no reformatting necessary.
I also notice in your code, you PasteSpecial, but don't specify what type of special paste. See the Microsoft (or this one) page for more info.
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
I tried putting the program into VBA, but I keep getting an error. This line was highlighted:
B(i, j) = C(i, j) + A(i + 1, j) * A(i, j + 1)
I am trying to multiply two of the same matrices and then add it to itself.
Suppose I wanted to multiply a 15 x 15 matrix, would I use the same codes except just change the dimensions and ranges?
Sub testing()
Dim A As Variant
Dim B(1 To 2, 1 To 2)
Dim C(1 To 2, 1 To 2)
A = Range("A1:B2").Value
i = 1
C(1, 1) = 0
Do Until i = 3
j = 1
Do Until j = 3
C(i, j) = C(i, j) + A(i, j) * A(j, i)
**B(i, j) = C(i, j) + A(i + 1, j) * A(i, j + 1)**
j = j + 1
Loop
i = i + 1
Loop
Range("E1:F2").Value = B
End Sub
Thanks!
Do...Loop is not the right tool for this job. Use For...Next instead. Also, to help make sure you don't overrun the array bounds and get a subscript out of range error, you can use LBound and UBound instead of hard-coding the index bounds. That way you don't have to change the code if you change the size of your input matrix.
This will get you part of the way. For simplicity I assumed A is a square matrix.
Dim i As Long, j As Long
Dim A As Variant
Dim B() As Variant
Dim C() As Variant
A = Range("A1:B2").Value
ReDim B(LBound(A, 1) To UBound(A, 1), LBound(A, 2) To UBound(A, 2))
ReDim C(LBound(A, 1) To UBound(A, 1), LBound(A, 2) To UBound(A, 2))
For i = LBound(A, 1) To UBound(A, 1)
For j = LBound(A, 2) To UBound(A, 2)
C(i, j) = C(i, j) + A(i, j) * A(j, i)
B(i, j) = C(i, j) + A(i + 1, j) * A(i, j + 1) ' still bad
Next j
Next i
Now you'll still get an error on that same line, due to the i+1 and j+1 indices. Those will have a value of 3 at some point, which is beyond your array bounds of 2. I can't help you fix that line, because I don't understand what you are trying to do with it.
Which brings me to my next point: if you think you're doing a matrix multiplication with this line
C(i, j) = C(i, j) + A(i, j) * A(j, i)
then you are wrong. The correct definition is:
and this is not what you have implemented.
A perhaps more convenient way to do it is to use the built-in MMult function:
C = WorksheetFunction.MMult(A, A)
I am trying to write a general code for matrix multiplication but when I am trying to verify it, the output is always a null matrix. So it seems that the values of the temp matrix are not getting updated.
Please suggest some changes for it to work. The code is copied below:
Public Function matrixmultiply(x() As Double, y() As Double) As Double()
Dim nrow1 As Integer, nrow2 As Integer, ncol1 As Integer, ncol2 As Integer, i As Integer, j As Integer, k As Integer, temp() As Double
nrow1 = UBound(x, 1) - LBound(x, 1) + 1
ncol1 = UBound(x, 2) - LBound(x, 2) + 1
nrow2 = UBound(y, 1) - LBound(y, 1) + 1
ncol2 = UBound(y, 2) - LBound(y, 2) + 1
ReDim matrixmultiply(1 To nrow1, 1 To ncol2)
ReDim temp(1 To nrow1, 1 To ncol2)
For i = 1 To nrow1
For j = 1 To ncol2
d = 2
For k = 1 To col1
temp(i, j) = temp(i, j) + x(i, k) * y(k, j)
Next k
Next j
Next i
matrixmultiply = temp
End Function
Private Sub CommandButton1_Click()
Dim x(1 To 3, 1 To 3) As Double, y(1 To 3, 1 To 3) As Double, z() As Double
Dim i As Integer, j As Integer
For i = 1 To 3
For j = 1 To 3
x(i, j) = Cells(i, j).Value
y(i, j) = Cells(i, j + 5).Value
Next j
Next i
z = matrixmultiply(x, y)
For i = 1 To 3
For j = 1 To 3
Cells(i, j + 12).Value = z(i, j)
Next j
Next i
End Sub
Silly mistake in the line:
For k = 1 To col1
It should, instead, be
For k = 1 To ncol1
Using Option Explicit would have saved a lot of hurt!