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
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
So I have data with around 20,000 records. I want to set the range such that only data from Row 2 to 20,000 is checked in column A. However, cell 20,001 isn't blank, it could contain spaces as well.
(This data is imported prior to validation, so I cannot alter it)
When I use .End(xlUp) it ends up checking till some 50,000th row.
Any Help?
Sample:
Column A
A
B
(2 spaces inserted)
I want to check for cells only till B(including it)
Update:
Managed to return the last required cell to the main sub
Private Sub last()
Dim rngX As Range
Set rngX = ActiveSheet.Range("A1").EntireColumn.Find(" ", lookat:=xlPart)
If Not rngX Is Nothing Then
/* return value
End If
End Sub
GD pnuts,
If you want to use VBA, you could contemplate checking for [space] character ? assuming the cell contains only spaces (or only one for that matter)
Something like:
Dim r as range
set r = range("B")
For each c in r.rows
if instr(1, c.value,chr(32)) > 0 then
'do something
end if
next
You could function a check of all characters in cell.value string to validate that they are only spaces ?
Does that help ?
I believe you will have to test each cell individually. To make the number of cells to check smaller, and to speed things up, I would first read the column to check into a Variant array, and then check that from bottom to top. I the spaces are truly a space, the test below will work. If the space is a NBSP, or a combination, then you will have to revise the check to ensure that is the only thing present.
e.g: to check column A:
Option Explicit
Sub foo()
Dim R As Range
Dim WS As Worksheet
Dim V As Variant
Dim I As Long
Set WS = Worksheets("sheet2")
With WS
V = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
For I = UBound(V) To LBound(V) Step -1
'Revise this check line as needed
If Len(Trim(V(I, 1))) > 0 Then Exit For
Next I
Set R = .Cells(I, 1)
End With
Debug.Print R.Address
End Sub
You might want to add some error checking in case all of the cells are empty.
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