I have written a small script in VBA which checks the value of a cell in a given range against a list. If the cell values match a value in the list it is kept, else it is deleted. I was wondering how I could make it run backward, as running it forwards creates issues. I have researched this somewhat and I have tried appending 'Step -1' to the end of the line which begins the for loop, but this doesn't work in this case.
Set Rng = Range("A9:V9")
For Each cell In Rng
If Not myList.Exists(cell.Value) Then
cell.EntireColumn.Delete
End If
Next
In this case, probably some for-loop like this one would be enough:
Option Explicit
Sub TestMe()
Dim rng As Range
Dim cnt As Long
Set rng = Range("A9:V9")
For cnt = rng.Cells.Count To 1 Step -1
Cells(rng.Row, cnt) = 23
Stop
Next
End Sub
I have put Stop so you can see which cell is referred. Once you hit the Stop, continue further with F5.
Richard, you're entirely right that the "Step -1" approach would be the right solution in this case. You simply have to change the variable references around to work with the loop.
For example:
Set Rng = Range("A9:V9")
For i = rng.rows.count to 1 step -1
for j = rng.columns.count to 1 step -1
if not myList.Exists(rng.cells(i, j).value) then
rng.cells(i, j).entirecolumn.delete ' This probably won't work, but you get the idea.
end if
next j
next i
Related
I have written a small script in VBA which checks the value of a cell in a given range against a list. If the cell values match a value in the list it is kept, else it is deleted. I was wondering how I could make it run backward, as running it forwards creates issues. I have researched this somewhat and I have tried appending 'Step -1' to the end of the line which begins the for loop, but this doesn't work in this case.
Set Rng = Range("A9:V9")
For Each cell In Rng
If Not myList.Exists(cell.Value) Then
cell.EntireColumn.Delete
End If
Next
In this case, probably some for-loop like this one would be enough:
Option Explicit
Sub TestMe()
Dim rng As Range
Dim cnt As Long
Set rng = Range("A9:V9")
For cnt = rng.Cells.Count To 1 Step -1
Cells(rng.Row, cnt) = 23
Stop
Next
End Sub
I have put Stop so you can see which cell is referred. Once you hit the Stop, continue further with F5.
Richard, you're entirely right that the "Step -1" approach would be the right solution in this case. You simply have to change the variable references around to work with the loop.
For example:
Set Rng = Range("A9:V9")
For i = rng.rows.count to 1 step -1
for j = rng.columns.count to 1 step -1
if not myList.Exists(rng.cells(i, j).value) then
rng.cells(i, j).entirecolumn.delete ' This probably won't work, but you get the idea.
end if
next j
next i
Essentially, when running the below code within one workbook (1 sheet) it completes within an instant. But when using it in my main workbook (couple of sheets, barely any data) it takes a while to complete. How can I optimize the below code?
Sub DeleteBlankRows()
On Error Resume Next
Sheets("Sheet4").Activate
Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Try avoiding the use of an entire column, as well as .Activate:
Sub DeleteBlankRows()
' On Error Resume Next
Dim lastRow As Long
With Sheets("Sheet4")
lastRow = .Cells(Rows.Count, 4).End(xlUp).row
.Range(.Cells(1, 4), .Cells(lastRow, 4)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub
Edit: Commented out the On Error Resume Next
you could try too to stop the automatic calculation and screen update and at the end reenable all.
try this and test too with the other codes
Sub DeleteBlankRows()
Application.ScreenUpdating = False
Application.Calculation = xlManual
On Error Resume Next
Sheets("Sheet4").Activate
Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = true
Application.Calculation = xlAutomatic
End Sub
Good Luck
lastRow = .Cells(Rows.Count, 4).End(xlUp).row
I never use this method for figuring out last row. It takes too long... Basically processing every cell starting from the bottom of the worksheet. Instead, I count the number of cells with values. I use that number to run a for loop which tests to see if there is a value in a given cell and counts until all cells with values are accounted for. Code wise, its more complicated... but in my experience executes more quickly.
kount = Application.WorksheetFunction.CountA(krng) 'Count how many used cells there are
kRow = 1
j = 1
Do Until j = kount + 1 'Do until all used cells are acounted for
If Cells(kRow, l).Value = vbNullString Then 'If current cell is empty skip it
Else
j = j + 1 'If the current cell has a value count up
End If
kRow = kRow + 1 'but go on to the next row either way
Loop
Where kRow is the last row with a value
I have a monthly base with almost 373,000 lines. Of these, part has a low value or is blank. I'd like to erase this lines.
I have part of this code to delete those that have zero. How to create a code that joins the empty row conditions (column D) in a more agile way.
Thanks
Sub DelRowsZero()
Dim i As Long
For i = Cells(Rows.Count, "D").End(xlUp).Row To 2 Step -1
If Cells(i, "D") = 0 Then Rows(i).Delete
Next i
End Sub
How about:
Sub ZeroKiller()
Dim N As Long, ToBeKilled As Range
Dim i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If Cells(i, "D").Value = 0 Or Cells(i, "D").Value = "" Then
If ToBeKilled Is Nothing Then
Set ToBeKilled = Cells(i, "D")
Else
Set ToBeKilled = Union(ToBeKilled, Cells(i, "D"))
End If
End If
Next i
If Not ToBeKilled Is Nothing Then
ToBeKilled.EntireRow.Delete
End If
End Sub
This assumes that A is the longest column. If this is not always the case, use:
N = Range("A1").CurrentRegion.Rows.Count
I am concerned about the 375K lines, who knows how long this will take to run.
Sub Button1_Click()
Dim i As Long
For i = Cells(Rows.Count, "D").End(xlUp).Row To 2 Step -1
If Cells(i, "D") = 0 Or Cells(i, "D") = "" Then
Rows(i).Delete
End If
Next i
End Sub
I'm curious to know if this works for others, it just uses the "replace" 0 values to blanks, then uses specialcells to delete the blank rows. My test of 38K rows takes 3 seconds.
Sub FindLoop()
Dim startTime As Single
startTime = Timer
'--------------------------
Columns("D:D").Replace What:="0", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'---------------------------------
Debug.Print Timer - startTime
End Sub
There's apparently an argument to be made, that deleting rows as you find them would be faster than deleting them all at once.
So I ran the below code with 36000 rows of =RANDBETWEEN(0, 10) in columns A and B (and then copy+paste special/values), and it completed thrice in 32 seconds and dusts.
Uncommenting the currentValue assignment and replacing the array subscript accesses with currentValue comparisons adds 2.5 seconds overhead; uncommenting the IsError check adds another 3.5 seconds overhead - but then the code won't blow up if the checked cells have the slightest chance of containing some #REF! or #VALUE! error.
Every time I ran it, ~4000 rows ended up being deleted.
Note:
No implicit ActiveSheet references. The code works against Sheet2, which is the code name for Worksheets("Sheet2") - a globally scoped Worksheet object variable that you get for free for any worksheet that exists at compile-time. If the sheet you're running this against exists at compile-time, use its code name (that's the (Name) property in the Properties toolwindow / F4).
Range is hard-coded. You already know how to get the last row with data, so I didn't bother with that. You'll want to dump your working range in a variant array nonetheless.
The commented-out code can be ignored/deleted if there's no way any of the cells involved have any chance of ever containing a worksheet error value.
Public Sub SpeedyConditionalDelete()
Dim startTime As Single
startTime = Timer
'1. dump the contents into a 2D variant array
Dim contents As Variant
contents = Sheet2.Range("A1:B36000").Value2
'2. declare your to-be-deleted range
Dim target As Range
'3. iterate the array
Dim i As Long
For i = LBound(contents, 1) To UBound(contents, 1)
'4. get the interesting current value
'Dim currentValue As Variant
'currentValue = contents(i, 1)
'5. validate that the value is usable
'If Not IsError(currentValue) Then
'6. determine if that row is up for deletion
If contents(i, 1) = 0 Or contents(i, 1) = vbNullString Then
'7. append to target range
If target Is Nothing Then
Set target = Sheet2.Cells(i, 1)
Else
Set target = Union(target, Sheet2.Cells(i, 1))
End If
End If
'End If
Next
'8. delete the target
If Not target Is Nothing Then target.EntireRow.Delete
'9. output timer
Debug.Print Timer - startTime
End Sub
Of course 375K rows will run much longer than 32-38 seconds, but I can't think of a faster solution.
I have an array of about 400 columns and 30 rows
I want to go through all the columns and each row in every column, and test cell of each cell for something..like if it's holds a negative number, and if it does I want to copy the cell itself and certain cells above it to another sheet.
I have done this with 2 standard "for-loop", however it takes a lot of time and there are more than 10 different tests for each cell.
I was wondering if anyone knew a more efficient way of doing this, such as using "for each" statements...I've been trying this with no luck -
Set FinalSht = ActiveWorkbook.Worksheets("Final")
Cnter = FinalSht.Cells(5, FinalSht.Columns.Count).End(xlToRight).Column
Rowter = FinalSht.Cells(FinalSht.Rows.Count, "B").End(xlUp).Row
Set AnRe = ActiveWorkbook.Worksheets("Anomaly")
AnRe.Cells.ClearContents
Set SRng = FinalSht.Range(FinalSht.Cells(5, 3), FinalSht.Cells(14, Cnter))
RowCount = 0
ColCount = 0
For Each RowRng In SRng.Rows
RowCount = RowCount + 1
For Each ColRng In SRng.Columns
ColCount = ColCount + 1
Select Case True
Case FinalSht.Cells(RowRng.Rows, ColRng.Columns) < 0
With AnRe
.Cells(RowCount, ColCount).Value = FinalSht.Cells(RowRng.Rows, ColRng.Columns).Value
End With
End Select
Next ColRng
Next RowRng
thanks for any help I can get...
A few general things to check if your code is slow:
Declare your variables to fit your data, see here for more info
Get rid of unused variables, code parts
Check out this for some ideas on how to use the for each loop (you don't need two for each loops to go through all cells in a range). For each is generally faster than for loops.
You really need to optimize your loops: make sure you only loop through what you really need to.
Also, optimize whatever is inside your loops. Make sure you are only doing whatever is necessary to do inside the loop, because that is what matters.
About your code:
Basically your code was slow because of two things.
Cnter = FinalSht.Cells(5, FinalSht.Columns.Count).End(xlToRight).Column
That xlToRight made it loop through 16000+ columns, instead of just 400. Big difference. All the rest I'm telling you is just 1% of the speed gain. When you are debugging a code, step through it with F8, and use watches or the locals window. More info here.
The other problem was having two for each loops instead of just the one you actually need.
The below code took less than a second to run. Hope this helps.
Sub test()
Dim Finalsht As Worksheet
Dim AnEr As Worksheet
Dim Cnter As Integer
Dim Rownter As Long
Dim SRng As Range
Dim myCell As Range
Set Finalsht = ActiveWorkbook.Worksheets("Final")
Cnter = Finalsht.Cells(5, Finalsht.Columns.Count).End(xlToLeft).Column
Rowter = Finalsht.Cells(Finalsht.Rows.Count, 2).End(xlUp).Row
Set AnRe = ActiveWorkbook.Worksheets("Anomaly")
AnRe.Cells.ClearContents
Set SRng = Finalsht.Range(Finalsht.Cells(5, 3), Finalsht.Cells(14, Cnter))
For Each myCell In SRng
Select Case True
Case myCell.Value < 0
With AnRe
.Cells(myCell.Row, myCell.Column).Value = myCell.Value
End With
End Select
Next myCell
End Sub
Edited
this is the code that answers the question
Dim i As Integer
For i = 1 To Sheet1.UsedRange.Rows.Count
If Cells(i, "C") <> "Q" Then
Sheet1.Rows(i).EntireRow.Copy Sheets("Sheet2").Cells(i, 1)
End If
Next
edit2
I'm now facing minor problems it would be great to figure out what's wrong with them.
1- This code is copying the cells but the problem is after pasting them in the other sheet there is gaps all over the place (they are the places of non-copied cells)
Dim i As Integer
For i = 1 To Sheet1.UsedRange.Rows.Count
If Cells(i, "P") <> "Q" Then
Sheet1.Rows(i).EntireRow.Copy Sheets("Sheet2").Cells(i, 1)
End If
Next
the fix for this problem is to add
.End(xlUp).Offset(1, 0)
after the line that does the copy and pasting. I tried that before but i used Offset(1) and that didn't work
2-This code causes Excel to hang and i have to force it to close but when i reopen it the copied cells are there in the new sheet(i kind of know the problem, i think it's because Excel will check all cells since they are = 0 but i tried using the same for loop as the previous code but i kept getting errors)
Dim ro As Long
For Each cell In Sheets("Sheet1").range("U:U")
If (Len(cell.Value) = 0) Then
ro = (ro + 1)
Sheets("Sheet1").Rows(cell.Row).Copy Sheets("Sheet3").Rows(ro)
End If
Next
the fix for #2 is to add a for loop of the rows count and include it, i knew that would fix it but i had problems with the syntax. The code needed the change in this line:
For Each cell In Sheets("Sheet1").range("U" & i)
"i" being the for loop, just like the one in code #1
This code will iterate all of your rows in Column A and check if the text is a Q, W or E. If it isn't it'll copy that row.
Sub Test()
Dim i As Integer
'Loop to move through the rows
For i = 1 To ActiveSheet.UsedRange.Rows.Count
'Checks if it contains Q, W or E
If Cells(i, 1) <> "Q" And Cells(i, 1) <> "W" And Cells(i, 1) <> "E" Then
'Copy that row
Rows(i).Copy
'You said you know how to do the copy part so I won't include the rest...
Else
'Do something else
End If
Next
End Sub
Next time actually attempt the problem before asking for help. If it weren't so simple, people probably wouldn't help out too much. This is also something which is a quick google or SO search away.
AutoFilter does this quickly by avoiding loops, and will avoid the gaps on the rows copy
If you do have lower case q or w data then an advanced filter using EXACT will be needed on the output in the second sheet. See Debra's example here
Sub Clean()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
Set rng1 = ws1.Range(ws1.[a1], ws1.Cells(Rows.Count, "A").End(xlUp))
With rng1
.AutoFilter Field:=1, Field:=1, Criteria1:="<>Q", Operator:=xlAnd, Criteria2:="<>W"
If rng1.Cells.Count > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy ws2.[a1]
End With
ws1.AutoFilterMode = False
End Sub