I have 234,000 rows of data and a macro that applies formatting to it. The macro takes about a minute to run. I'm trying to cut the time down if possible.
Each time there is a change in column 1 a border is added and all data after the second column has a boarder added between each row and gets colored.
Here is an example of the data:
This is the macro:
Sub FormatData()
Dim PrevScrnUpdate As Boolean
Dim TotalRows As Long
Dim TotalCols As Integer
Dim PrevCell As Range
Dim NextCell As Range
Dim CurrCell As Range
Dim i As Long
Dim StartTime As Double
StartTime = Timer
PrevScrnUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
TotalRows = Rows(ActiveSheet.Rows.Count).End(xlUp).row
TotalCols = Columns(ActiveSheet.Columns.Count).End(xlToLeft).Column
Range(Cells(1, 1), Cells(1, TotalCols)).Font.Bold = True
For i = 2 To TotalRows
Set NextCell = Cells(i + 1, 1)
Set CurrCell = Cells(i, 1)
Set PrevCell = Cells(i - 1, 1)
If CurrCell.Value <> NextCell.Value Then
Range(CurrCell, Cells(i, 2)).Borders(xlEdgeBottom).LineStyle = xlSolid
End If
If CurrCell.Value <> PrevCell.Value Then
Range(CurrCell, Cells(i, 2)).Borders(xlEdgeTop).LineStyle = xlSolid
End If
Range(Cells(i, 3), Cells(i, TotalCols)).BorderAround xlSolid
Range(Cells(i, 3), Cells(i, TotalCols)).Interior.Color = RGB(200, 65, 65)
Next
Application.ScreenUpdating = PrevScrnUpdate
Debug.Print Timer - StartTime
End Sub
Edit: Here is an example of the result:
Edit 2: I have tried this with arrays and it does not improve the speed.
I'd probably start thinking in terms of putting the column you need to loop over in an array and comparing adjacent strings. Then do the update. Loop and comparison should be faster over the array with probably the same overhead for the border formatting.
Dim ii As Long, firstRow As Integer ' a counter variable and the first row offset
Dim myColumn() As String ' create a string array
ReDim myColumn(firstRow To firstRow + TotalRows) ' resize to hold the number of rows of data
myColumn = Range(Cells(1,1),Cells(1,TotalRows)).Value ' write the range to the array
For ii = (LBound(myColumn) + 1) To (UBound(myColumn) - 1)
If myColumn(ii) <> myColumn(ii+1) Then
Range(Cells(ii,1),Cells(ii,Ncol)).Borders(xlEdgeBottom).LineStyle = xlSolid
Else If myColumn(ii) <> myColumn(ii-1)
Range(Cells(ii,1),Cells(ii,Ncol)).Borders(xlEdgeTop).LineStyle = xlSolid
End If
Next
I almost always try to get big lists into a typed array if I know I need to iterate unless it's a trivial amount of data. The other option might be to copy the entire range into an array of type Range, update the rows that match on that value, then put them back again.
Dim myColumns() As Range
ReDim myColumns(1 To TotalRows,1 To TotalCols)
myColumns = Range(Cells(1,1),Cells(TotalRows,TotalCols)
For ii = LBound(myColumns,1) + 1 To UBound(myColumns,1) - 1
If myColumns(ii,1) <> myColumns(ii+1,1) Then
' ... update the bottom border
Else If myColumns(ii,1) <> myColumns(ii-1,1) Then
' ... update the top border
End If
Next
' Once we've done the updates, put the array back in place
Range(Cells(1,1),Cells(TotalRows,TotalCols)) = myColumns
Related
a report I pull gives me an excel spreadsheet that splits the data for each entry across three rows in excel. I'm trying to figure out the best way to combine the three rows into one row so each field is in it's own column.
Each three row cluster is separated by a blank row and each of the data rows has five columns. The first cluster starts on row 4.
I have a macro (shown below) that does this correctly, but not efficiently. The spreadsheets I get have many (up to a million) rows in them.
I was originally using the cut and paste commands and that was really slow. I found that directly setting .value make it quite a bit faster but this is still way to slow.
I think that the right answer is to do all of the manipulation in memory and write to the actual excel range only once, but I'm at the limits of my VBA foo.
Option Explicit
Sub CombineRows()
Application.ScreenUpdating = False
Dim currentRow As Long
Dim lastRow As Long
Dim pasteColumn As Long
Dim dataRange As Range
Dim rowEmpty As Boolean
Dim firstOfGroup As Boolean
Dim data As Variant
Dim rw As Range
pasteColumn = 6
rowEmpty = True
firstOfGroup = True
currentRow = 4
lastRow = 30
Set dataRange = Range(Cells(currentRow, 1), Cells(lastRow, 5))
For Each rw In dataRange.Rows
Debug.Print rw.Row
If WorksheetFunction.CountA(Range(Cells(rw.Row, 1), Cells(rw.Row, 5))) = 0 Then
If rowEmpty Then Exit For
currentRow = rw.Row + 1
rowEmpty = True
Else
If Not rowEmpty Then
Range(Cells(currentRow, pasteColumn), Cells(currentRow, pasteColumn + 4)).value = Range(Cells(rw.Row, 1), Cells(rw.Row, 5)).value
Range(Cells(rw.Row, 1), Cells(rw.Row, 5)).value = ""
Debug.Print "pasteColumn:"; pasteColumn
If pasteColumn = 6 Then
pasteColumn = 11
ElseIf pasteColumn = 11 Then
pasteColumn = 6
End If
End If
rowEmpty = False
End If
Next
Application.ScreenUpdating = True
End Sub
Update: After I posted this, I noticed that I still had those Debug.Print statements in there. Once I removed those, the performance improved from execution times on the order of hours to a minute or two.
I still thing that this is unnecessarily slow so I'm still interested in any answer that can explain the right way to minimize the VBA <-> excel interactions.
If I understand correctly your question, you want to copy some data.
I recommend you to use an array.
Sub data()
Dim data() As String 'Create array
Dim column as integer
column = 0
For i = 0 To 100000 'See how many columns are in the line
If IsEmpty(Cells(rowNum, i+1)) = False Then
column = column + 1
Else
Exit For
End If
Next
ReDim date(column) As String 'Recreat the array, with the excat column numer
For i = 0 To column - 1
data(i, j) = Cells(rowNum, i + 1) 'Puts data into the array
Next
End sub()
And now you just have to insert the data from the array to the correct cell.
#Cubbi is correct. You can use an array to do all of your data manipulation and then write to the worksheet only once at the end. I've adapted your code to use an array to combine the three rows into a single row for each of the groups. Then at the end it selects "Sheet2" and pastes in the collected data. Note, this is not an in-place solution like yours, but it is super fast:
Option Explicit
Sub AutitTrailFormat()
Application.ScreenUpdating = False
Dim dataArray() As String
Dim currentRow As Long
Dim lastRow As Long
Dim pasteColumn As Long
Dim dataRange As Range
Dim rowEmpty As Boolean
Dim firstOfGroup As Boolean
Dim data As Variant
Dim rw As Range
Dim i, j, k As Long
Dim Destination As Range
pasteColumn = 6
rowEmpty = True
firstOfGroup = True
currentRow = 4
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet1").Select
Set dataRange = Worksheets("Sheet1").Range(Cells(currentRow, 1), Cells(lastRow, 5))
data = dataRange.Value
ReDim dataArray(UBound(data, 1), 15)
j = 1
k = 1
For i = 1 To UBound(data, 1)
If data(i, 1) = "" And data(i, 2) = "" And data(i, 3) = "" And data(i, 4) = "" And data(i, 5) = "" Then
j = j + 1
k = 1
Else
dataArray(j, k + 0) = data(i, 1)
dataArray(j, k + 1) = data(i, 2)
dataArray(j, k + 2) = data(i, 3)
dataArray(j, k + 3) = data(i, 4)
dataArray(j, k + 4) = data(i, 5)
k = k + 5
End If
Next
Worksheets("Sheet2").Select
Set Destination = Worksheets("Sheet2").Range(Cells(1, 1), Cells(UBound(dataArray, 1), 16))
Destination.Value = dataArray
Application.ScreenUpdating = True
End Sub
My worksheet have 6000 rows. This loop takes me more than 20minutes to finish. It is too long for me because I have many columns to run this loop. Can someone help me?
Dim i As Integer
For i = ActiveCell.Row To 5771
If Cells(i, ActiveCell.Column - 1).Value = 0 And Cells(i, ActiveCell.Column).Value = "" Then
Cells(i, ActiveCell.Column).Value = 0
ElseIf Cells(i, ActiveCell.Column - 1).Value = 1 Then
Range(Cells(i, ActiveCell.Column), Cells(i + 9, ActiveCell.Column)).Value = 1
ElseIf Cells(i, ActiveCell.Column - 1).Value = -1 Then
Range(Cells(i, ActiveCell.Column), Cells(i + 9, ActiveCell.Column)).Value = -1
End If
Next i
It is hard to tell exactly what you're trying to do. The loop structure you're using appears to be very inefficient: you're looping over rows in a range, and performing some evaluation/logic test on each cell.
If the adjacent (to the left) cell's value is 1 or -1, then you're filling the cell and the next 9 cells with that value. But then when you hit the Next in your loop, you will perform your test on those cells. So, either you should not be filling a value down 10 rows, or you should avoid testing those rows since presumably nothing needs to be done with them (otherwise you should not have filled them in in the first place!) So you can see why I am a little confused.
In any case, I assume that you do not need to test the 9 rows beneath when the Cells(i, ActiveCell.Column - 1).Value = 1 or Cells(i, ActiveCell.Column - 1).Value = -1.
I have not tested either of these so they may have some typos/etc.
The fastest method is to perform manipulations on yoru data in memory only. You can store the range's values in an array, and perform the operations on the array, and then "write" the values back to the worksheet in a single statement. Looping in memory is much faster than looping and writing on the worksheet.
Dim rng as Range
Dim arr as Variant
Dim val as Variant
Dim r as Long, i As Integer
Set rng = Range(Cells(ActiveCell.Row, ActiveCell.Column -1).Address, Cells(5771, ActiveCell.Column).Address)
'store the range values in a variant array:
' this will be of the structure arr(_row#_, _column#_)
arr = rng.Value
For r = 1 to UBound(arr, 1) 'Loop until last row in range/array
'arr(r,1) represents the first column of the range -- i.e., the column to left of ActiveCell
' so we can use a Case statement to check this value of either 0, 1, or -1.
Select Case arr(r, 1)
Case 0
'if the adjacent left cell = 0 AND this cell's value = ""
' then make this cell's value = 0.
If arr(r, 2) = "" Then arr(r, 2) = 0
Case 1, -1
For i = 0 to 10
'if the value is 1 or -1, puts the in this cell AND the next 9 cells
arr(r + i, 2) = arr(r, 1)
Next
'increment our iterator variable
r = r + 9
Case Else
'Do nothing...
End Select
Next
'put the transformed values in to the worksheet
rng.Value = arr
That is basically the same as this, which uses the worksheet object/cells in the loop. It more closely resembles your loop, but it will also be less efficient than the above.
'Alternatively, but this will be slower:
Dim rng as Range
Dim cl as Range
Dim i as Integer
Set rng = Range(Cells(ActiveCell.Row, ActiveCell.Column -1).Address, Cells(5771, ActiveCell.Column).Address)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For each cl in rng.Cells
With cl
Select Case .Offset(0, -1).Value
Case 0
If .Value = "" Then .Value = 0
Case 1, -1
.Resize(10,1).Value = .Offset(0, -1).Value
Case Else
'Do nothing
End Select
End With
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
The department that provides me a spreadsheet to be used in my database now includes multiple text in a cell. In order to link to that data I have to turn it into multiple rows. Example: LC123/LC463/LC9846 needs to have the entire row copied with just one "LC" string in each row-
cell1 cell2 LC123
cell1 cell2 LC463
cell1 cell2 LC9846
I tried these two subroutines but obviously it failed
Sub InSert_Row()
Dim j As Long
j = InputBox(=SUM(LEN(ActiveCell)-LEN(SUBSTITUTE(ActiveCell,"LC",""))-1)
ActiveCell.EntireRow.Copy
ActiveCell.Offset(j).EntireRow.Insert Shift:=xlDown
End Sub
Sub SplitAndTranspose()
Dim N() As String
N = Split(ActiveCell, Chr(10))
ActiveCell.Resize(UBound(N) + 1) = WorksheetFunction.Transpose(N)
End Sub
The 2nd subroutine will split and copy but it doesn't insert rows, it writes over the rows below it.
'In memory' method
Inserting rows as necessary would be perhaps the most simple to understand, but the performance of making thousands of seperate row inserts would not be good. This would be fine for a one off (perhaps you only need a one-off) and should only take a minute or two to run but I thought what the heck and so wrote an approach that splits the data in memory using a collection and arrays. It will run in the order of seconds.
I have commented what it is doing.
Sub ProcessData()
Dim c As Collection
Dim arr, recordVector
Dim i As Long, j As Long
Dim rng As Range
Dim part, parts
'replace with your code to assign the right range etc
Set rng = ActiveSheet.UsedRange
j = 3 'replace with right column index, or work it out using Range.Find etc
arr = rng.Value 'load the data
'Process the data adding additional rows etc
Set c = New Collection
For i = 1 To UBound(arr, 1)
parts = Split(arr(i, j), "/") 'split the data based on "/"
For Each part In parts 'loop through each "LC" thing
recordVector = getVector(arr, i) 'get the row data
recordVector(j) = part 'replace the "LC" thing
c.Add recordVector 'add it to our results collection
Next part
Next i
'Prepare to dump the data back to the worksheet
rng.Clear
With rng.Parent
.Range( _
rng.Cells(1, 1), _
rng.Cells(1, 1).Offset(c.Count - 1, UBound(arr, 2) - 1)) _
.Value = getCollectionOfVectorsToArray(c)
End With
End Sub
'Helper method to return a vector representing our row data
Private Function getVector(dataArray, dataRecordIndex As Long)
Dim j As Long, tmpArr
ReDim tmpArr(LBound(dataArray, 2) To UBound(dataArray, 2))
For j = LBound(tmpArr) To UBound(tmpArr)
tmpArr(j) = dataArray(dataRecordIndex, j)
Next j
getVector = tmpArr
End Function
'Helper method to return an array from a collection of vectors
Function getCollectionOfVectorsToArray(c As Collection)
Dim i As Long, j As Long, arr
ReDim arr(1 To c.Count, LBound(c(1), 1) To UBound(c(1), 1))
For i = 1 To c.Count
For j = LBound(arr, 2) To UBound(arr, 2)
arr(i, j) = c(i)(j)
Next j
Next i
getCollectionOfVectorsToArray = arr
End Function
Edit:
Alternative "Range Insert" method.
It will be slower (although I made the number of discrete insert and copy operations be based on original row count, not some recursive sweep so it is not too bad) but is simpler to understand and so to perhaps tweak if needed. It should run in the order of a couple of minutes.
Sub ProcessData_RangeMethod()
Dim rng As Range
Dim colIndex As Long
Dim parts
Dim currRowIndex As Long
'replace with your code to assign the right range etc
Set rng = ActiveSheet.UsedRange
colIndex = 3 'replace with right column index, or work it out using Range.Find etc
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
currRowIndex = 1
Do Until currRowIndex > rng.Rows.Count
parts = Split(rng.Cells(currRowIndex, colIndex), "/")
If UBound(parts) > 0 Then
rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count)).Insert xlShiftDown
rng.Rows(currRowIndex).Copy rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count))
rng.Range(rng.Cells(currRowIndex, colIndex), rng.Cells(currRowIndex + UBound(parts), colIndex)).Value = Application.Transpose(parts)
End If
currRowIndex = currRowIndex + 1 + UBound(parts)
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I am looking to find out how I can remove ALL duplicate rows (when duplicates exist in the first column) using a VBA macro.
Currently Excel macros delete all duplicate instances EXCEPT for the first instance, which is totally not what I want. I want absolute removal.
A bit shorter solution done for quick morning training:
Sub quicker_Option()
Dim toDel(), i As Long
Dim RNG As Range, Cell As Long
Set RNG = Range("a1:a19") 'set your range here
For Cell = 1 To RNG.Cells.Count
If Application.CountIf(RNG, RNG(Cell)) > 1 Then
ReDim Preserve toDel(i)
toDel(i) = RNG(Cell).Address
i = i + 1
End If
Next
For i = UBound(toDel) To LBound(toDel) Step -1
Range(toDel(i)).EntireRow.Delete
Next i
End Sub
Store the first instance's cell for later deleting.
Then go deleting duplicates until the end.
Dim F as integer, S as integer 'indices for First and Second cells to be compared
Dim Deleted as boolean 'indicates if second line was deleted
Dim First as Range, Second as Range 'First and second cells to be compared
Dim Start as string 'Indicates the position of the first cell's start
Start = "A1" 'can be as you like
Set First = Sheet1.Range(Start) 'Sets the start cell
F = 0 '
Do While First.Value <> "" 'loop while sheet contains data in the column
S = F + 1 'second cell is at least 1 cell below first cell
Deleted = false 'no second cell was deleted yet
Set Second = First.Offset(S,0) 'second cell is an offset of the first cell
Do While Second.Value <> "" 'loop while second cell is in sheet's range with data
if Second.Value = First.Value then 'if values are duplicade
Second.EntreRow.Delete 'delete second cell
Deleted = true 'stores deleted information
else 'if not, second cell index goes next
S = S + 1;
end if
Set Second = First.Offset(S, 0) 'sets second cell again (if deleted, same position, if not deleted, next position
Loop
if Deleted then 'if deleted, should delete first cell as well
First.EntireRow.Delete
else
F = F + 1 'if no duplicates found, first cell goes next
end if
Set First = Sheet1.Range(Start).Offset(F,0) 'sets first cell again (if deleted, same position, if not, next)
Loop
I am using this code to create an Auto reconciliation of general ledger control accounts where if any cell with equal value but opposite sign is cut to sheet 2; hence left with only reconciliation item.
the code:
sub autoRecs()
dim i as long
Application.ScreenUpdating = False
Application.StatusBar = True
Dim i As Long
Cells(5, 6).Select
Dim x As Long
Dim y As Long
x = ActiveCell.Row
y = x + 1
Do Until Cells(x, 6) = 0
Do Until Cells(y, 6) = 0
Application.StatusBar = "Hey Relax! You can rely on me......"
If Cells(x, 6) = Cells(y, 6) * -1 Then
Cells(x, 6).EntireRow.Cut (Worksheets(2).Cells(x, 6).EntireRow)
Cells(y, 6).EntireRow.Cut (Worksheets(2).Cells(y, 6).EntireRow)
Cells(x, 6).Value = "=today()"
Cells(y, 6).Value = "=today()"
Else
y = y + 1
End If
Loop
x = x + 1
y = x + 1
Loop
Application.StatusBar = False
End Sub
Sub deleteBlankCells()`this is to delete unnecessary cells after run the above macro`
Range(Cells(5, 1), Cells(Rows.Count, 1).End(xlUp)).Select
For i = Selection.Rows.Count To 1 Step -1
Application.StatusBar = "OOH! I'm cleaning all the blanks for you....."
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
Application.StatusBar = False
End Sub
I like to work with arrays within VBA, so here is an example.
Assume the data represents the currentregion around A1, but that is easily changed
Read the source data into an array
Check each item in column one to ensure it is unique (countif of that item = 1)
If unique, add the corresponding row number to a Collection
Use the size of th collection and the number of columns to Dim a results array.
Cycle through the collection, writing the corresponding rows to a results array.
Write the results array to the worksheet.
As written, the results are placed to the right of the source data, but could also replace it, or be placed on a different sheet.
Option Explicit
Sub RemoveDuplicatedRows()
Dim vSrc As Variant, vRes() As Variant
Dim rSrc As Range, rRes As Range
Dim colUniqueRows As Collection
Dim I As Long, J As Long
'assume data starts in A1 and represented by currentregion
Set rSrc = Range("a1").CurrentRegion
vSrc = rSrc
Set rRes = rSrc.Offset(0, UBound(vSrc, 2) + 2)
'get collection of non-duplicated rows
Set colUniqueRows = New Collection
For I = 1 To UBound(vSrc)
If WorksheetFunction.CountIf(rSrc.Columns(1), vSrc(I, 1)) = 1 Then _
colUniqueRows.Add I
Next I
'Make up results array
ReDim vRes(1 To colUniqueRows.Count, 1 To UBound(vSrc, 2))
For I = 1 To UBound(vRes, 1)
For J = 1 To UBound(vSrc, 2)
vRes(I, J) = vSrc(colUniqueRows(I), J)
Next J
Next I
rRes.EntireColumn.Clear
rRes.Resize(UBound(vRes)) = vRes
End Sub
I currently have an array which I populate and paste in a sheet named "T1" using a macro. My current macro uses the rowcount function to determine the used rows and pastes the array from the next available row.
The problem I am having is that when I paste this array multiple times, the arrays need to be spaced by a row so that i can differentiate different submissions. This is what I have so far, and I was hoping someone could help me with this:
Sub CopyData()
Dim Truearray() As String
Dim cell As Excel.Range
Dim RowCount1 As Integer
Dim i As Integer
Dim ii As Integer
Dim col As Range
Dim col2 As Range
i = 0
ii = 2
RowCount1 = DHRSheet.UsedRange.Rows.Count
Set col = DHRSheet.Range("I1:I" & RowCount1)
For Each cell In col
If cell.Value = "True" Then
Dim ValueCell As Range
Set ValueCell = Cells(cell.Row, 3)
ReDim Preserve Truearray(i)
Truearray(i) = ValueCell.Value
Dim siblingCell As Range
Set siblingCell = Cells(cell.Row, 2)
Dim Siblingarray() As String
ReDim Preserve Siblingarray(i)
Siblingarray(i) = DHRSheet.Name & "$" & siblingCell.Value
i = i + 1
End If
Next
Dim RowCount2 As Integer
RowCount2 = DataSheet.UsedRange.Rows.Count + 1
For ii = 2 To UBound(Truearray)
DataSheet.Cells(RowCount2 + ii, 2).Value = Truearray(ii)
Next
For ii = 2 To UBound(Siblingarray)
DataSheet.Cells(RowCount2 + ii, 1).Value = Siblingarray(ii)
Next
DataSheet.Columns("A:B").AutoFit
MsgBox ("Data entered has been successfully validated & logged")
End Sub
If you Offset two rows from the bottom cell, you will leave a blank row of separation. You should also consider filling the whole array as base 1 and writing it to DataSheet in one shot.
Sub CopyData2()
Dim rCell As Range
Dim aTrues() As Variant
Dim rRng As Range
Dim lCnt As Long
'Define the range to search
With DHRSheet
Set rRng = .Range(.Cells(1, 9), .Cells(.Rows.Count, 9).End(xlUp))
End With
'resize array to hold all the 'trues'
ReDim aTrues(1 To Application.WorksheetFunction.CountIf(rRng, "True"), 1 To 2)
For Each rCell In rRng.Cells
If rCell.Value = "True" Then
lCnt = lCnt + 1
'store the string from column 2
aTrues(lCnt, 1) = DHRSheet.Name & "$" & rCell.Offset(0, -7).Value
'store the value from column 3
aTrues(lCnt, 2) = rCell.Offset(0, -6).Value
End If
Next rCell
'offset 2 from the bottom row to leave a row of separation
With DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Offset(2, 0)
'write the stored information at one time
.Resize(UBound(aTrues, 1), UBound(aTrues, 2)).Value = aTrues
End With
End Sub