Excel VBA delete row based on cell value [duplicate] - excel

I am running the following code on a spreadsheet:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
End If
i = i + 1
Loop
There are plenty of entries with not "String" but they do not get deleted.
When I copy this piece of code to a separate sheet, I even get the error "Excel cannot complete this task with available resources. Choose less data or close other applications."
What am I doing wrong that is making this loop not work?
Note: I can't use autofilter because I need to delete rows based on not meeting a condition.

This is the worst way to delete a row. Reasons
You are deleting the rows in a Loop
Your Cells Object are not qualified
Try this.
Co-incidentally I answered a similar question in the MSDN forum as well. Please See THIS
Try this way (UNTESTED)
In the below code I have hardcoded the last row to 100000 unlike as done in the above link.
Sub Sample()
Dim ws As Worksheet
Dim i As Long
Dim delRange As Range
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
For i = 1 To 100000
If .Cells(i, 4).Value <> "String" Then
If delRange Is Nothing Then
Set delRange = .Rows(i)
Else
Set delRange = Union(delRange, .Rows(i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.Delete
End With
End Sub
NOTE: I am assuming that a cell will have values like
String
aaa
bbb
ccc
String
If you have scenarios where the "String" can be in different cases or in between other strings for example
String
aaa
STRING
ccc
dddStringddd
then you will have to take a slightly different approach as shown in that link.

Autofilter code:
Sub QuickCull()
Dim rng1 As Range
Set rng1 = Range([d4], Cells(Rows.Count, "D").End(xlUp))
ActiveSheet.AutoFilterMode = False
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
With rng1
.AutoFilter Field:=1, Criteria1:="<>string"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then _
.Offset(1, 0).Resize(rng1.Rows.Count - 1).Rows.Delete
End With
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
ActiveSheet.AutoFilterMode = False
End Sub

When you want to delete rows its always better to delete from bottom.
Sub DeleteData()
Dim r As Long
Dim Rng As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("sheet1")
Set Rng = .Range(.Range("D1"), .Range("D1").End(xlDown))
For r = Rng.Rows.Count To 1 Step -1
If LCase(Trim(.Cells(r, 4).Value)) <> LCase("string") Then
.Cells(r, 4).EntireRow.Delete
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

This is a basic algorithm mistake.
Imagine your program are on, say, row 10. You delete it. So, row 11 becomes row 10, row 12 becomes 11 and so on. Then you go to row 11, skipping row 10, previous row 11!
This would work:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
Else
i = i + 1
End If
Loop

Related

Speed up checking every cell in a dynamic range

I need to speed up this macro & to avoid specifying a range as (A2:A2000) for example because my data is dynamic.
My macro checks every cell with the same value in some columns to merge it
Sub Merge_Duplicated_Cells()
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Cell As Range
' Merge Duplicated Cells
Application.DisplayAlerts = False
Sheets("1").Select
Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
CheckAgain:
For Each Cell In myrange
If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
Range(Cell, Cell.Offset(1, 0)).Merge
Cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
Sheets("2").Select
Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
For Each Cell In myrange
If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
Range(Cell, Cell.Offset(1, 0)).Merge
Cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
ActiveWorkbook.Save
MsgBox "Report is ready"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
For a quick fix add
Application.Calculation = xlManual
after your code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
and
Application.Calculation = xlAutomatic
after your code
Application.DisplayAlerts = True
Application.ScreenUpdating = True
and to improve the macro not processing blank ranges,
dim ws as worksheet
dim lastrowA, lastrowB, lastrow C as long
'Instead of setting last row to 2000, can use the actual last row by eg:
'find last row of data in column A'
lastrowA = ws.Cells(Rows.Count, 1).End(xlUp).Row
'find last row of data in column B'
lastrowB = ws.Cells(Rows.Count, 2).End(xlUp).Row
'find last row of data in column C'
lastrowC = ws.Cells(Rows.Count, 3).End(xlUp).Row
and insert these into the macro instead of 2000 eg:
Set myrange = Range("A2:A" & lastrowA & ,
The slowdown in your code is primarily due to the presence of the GoTo CheckAgain transition, due to which the cycle of processing the same cells is repeated many times. In addition, multiple calls to the cells of the sheet are used, which is very time consuming. In the code below, unnecessary cycles are excluded, reading data from the sheet, merging and formatting cells are performed immediately for the entire processed subrange.
I ran the code on 2 sheets with 10000 rows each, it took 2.6 sec.
Option Explicit
Sub test1()
'Here we indicate only the starting cells in each column, because
'the size of the non-empty area in these columns is calculated
'automatically in the MergeCells() procedure
MergeCells Sheets("1").Range("A2,B2,L2,M2,N2,O2")
MergeCells Sheets("2").Range("A2,B2,L2,M2,N2,O2")
End Sub
Sub MergeCells(myrange As Range)
Dim v As Variant, col As Range, Cell As Range, toMerge(0 To 1) As Range, k As Long, index As Byte, area As Variant, arr As Variant, skip As Boolean
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
For Each col In myrange
' next line reads all the data from sheet's column at once
arr = col.Resize(myrange.Parent.Cells(Rows.Count, col.Column).End(xlUp).Row - col.Row + 1)
For k = LBound(arr, 1) To UBound(arr, 1) - 1 'loop through all rows of an array
If Not skip And arr(k, 1) = arr(k + 1, 1) And Not IsEmpty(arr(k, 1)) Then
'to prevent "gluing" adjacent sub-ranges within the same range,
'two ranges are used in the toMerge array, all odd sub-ranges are collected
'in the element with index 0, all even ranges are collected in the element
'with index 1, and Index switches from 0 to 1 and vice versa after each array subrange
If toMerge(index) Is Nothing Then
Set toMerge(index) = col.Offset(k - col.Row + 1).Resize(2)
Else
Set toMerge(index) = Union(col.Offset(k - col.Row + 1).Resize(2), toMerge(index))
End If
index = 1 - index
skip = True ' if merged, skip next cell
Else
skip = False
End If
Next
' if the ranges for merge are non-empty, we merge and format simultaneously for all subranges
For Each area In toMerge
If Not area Is Nothing Then
area.Merge
area.VerticalAlignment = XlVAlign.xlVAlignCenter
End If
Next
Set toMerge(0) = Nothing
Set toMerge(1) = Nothing
Next
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
If I understand you correctly .... besides the already existing answer, another way (which is not meant to be better) maybe something like this :
Before and after running the sub (please ignore the yellow fill and the border, as it is used just to be easier to see the result) like image below :
===>
Sub test()
Dim LR As Integer: Dim cnt As Integer
Dim i As Integer: Dim c As Range
Application.DisplayAlerts = False
With ActiveSheet.UsedRange
LR = .Rows(.Rows.Count).Row
cnt = .Columns.Count
End With
For i = 1 To cnt
Set c = Cells(1, i)
Do
If c.Value <> "" And c.Value = c.Offset(1, 0).Value _
Then Range(c, c.Offset(1, 0)).Merge _
Else Set c = c.Offset(1, 0)
Loop Until c.Row > LR
Next
End Sub
LR is the last row of the used range of the active sheet.
cnt is the column count of the used range of the active sheet.
Then it loop from 1 to as many as the cnt as i variable.
Inside this loop, it create the starting cell as c variable, then do the inner loop, by checking each c within the looped column (the i in cnt) if the row below c has the same value then it merge this c and the c.offset(1,0). The inner loop stop when the c.row is larger than the LR, then it goes to the next i (the next column).
Please note, the data should start from column A ... because the outer loop assume that the column to be in the inner loop will start from column 1 (column A). And also, the code doesn't do any fancy things, such as alignment, font size, border, etc.

Looping through a range to find a value

I have a worksheet that has columns 1-8, rows 3 through the last row. I would like to loop through each cell to find out if a value of 1 is present. If it is then that row is copied and inserted for each value of 1, additionally that new row will have a text inserted in cell (13,row) then moved to the next row. This is as far as I got....thanks!
Sub Workcenter()
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
On Error GoTo 0
Dim Test As Worksheet
Set TS = Worksheets("Test")
Application.DisplayAlerts = True
For k = 1 To 8
For j = 4 To TS.Cells(Rows.Count, k).End(xlUp).Row
If TS.Cells(j, k).Value = 1 Then TS.Cells.Activate
'TS.Cells.Activate.Row.Select
Rows(ActiveCell.Row).Select
Selection.Copy
Selection.Insert Shift:=xlDown
'ShopOrderNumRow = j
Next j
Next k
End Sub
Will try giving some example knowing that I still don't understand how the inserting is occurring for each cell of a row.
Providing more detail, or example of before/after in your post may help.
As for an example, since you're marking only a single cell in each row, I would suggest Find() for value of 1 to determine if you need to write to that specific cell.
'untested code
sub test()
toggle false
dim rowNum as long
for rowNum = firstRow to lastRow Step 1
with sheets(1)
with .range(.cells(rowNum,1),.cells(rowNum,8))
dim foundCell as range
set foundCell = .find(1)
if not foundCell is nothing then .cells(rowNum,13).value = "text"
end with
end with
next iterator
toggle true
end sub
private sub toggle(val as boolean)
with application
.screenupdating = val
.enableevents = val
end with
end sub
Edit1: Looks like countif() may be the saviour here.
Edit2: Tested code input (untested code part of Edit1)
Sub test()
Dim lastRow As Long: lastRow = 10
Dim firstRow As Long: firstRow = 1
toggle False
Dim rowNum As Long
For rowNum = lastRow To firstRow Step -1
With Sheets(1)
Dim countRange As Range
Set countRange = .Range(.Cells(rowNum, 1), .Cells(rowNum, 8))
Dim countOfOnes As Long
countOfOnes = Application.CountIf(countRange, 1)
If countOfOnes > 0 Then
With .Rows(rowNum)
.Copy
.Offset(1).Resize(countOfOnes).Insert Shift:=xlDown
End With
.Cells(rowNum, 13).Value = "text"
End If
End With
Next rowNum
toggle True
End Sub
Private Sub toggle(val As Boolean)
With Application
.ScreenUpdating = val
.EnableEvents = val
End With
End Sub
Tested using this data:
Output from running code:

Macro to hide certain rows

Column A will always have the date and time in the pictured format, in 1 minute intervals for a whole month.
My first goal is to hide any rows that have a number less than 50 in column B.
Sub HideRows()
Application.ScreenUpdating = False
Application.Calculation = xlManual
For Each c In Range("B:B")
If c.Value < 50 And c.Value <> "" Then Rows(c.Row).Hidden = True
Next
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
That Macro works.
Then, I would also like to hide any consecutive rows that are between the first row starting with a number higher than 50, and the last row higher than 50.
Essentially, it would give me a start and stop time in column A for the flows over 50 in column B.
I don't know enough about coding to hide the times in-between the start and stop times.
Any help/suggestions are greatly appreciated!
Not the most elegant solution, but try this out
Sub StartEnd()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim cnt As Long
Dim cntTotal As Long
Set ws = ActiveSheet 'change sheet here if you want
With ws
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row
Set rng = .Range("B2:B" & lRow) 'excluding headers
cntTotal = Application.CountIf(rng, ">50") 'total occurences >50
For Each c In rng
If IsNumeric(c.value) And c.value > 50 Then
cnt = cnt + 1
Select Case cnt
Case 1, cntTotal: 'do nothing if first or last occurence
Case Else: .Rows(c.Row).Hidden = True 'else hide row
End Select
Else
.Rows(c.Row).Hidden = True 'hide row if <50
End If
Next
End With
End Sub
Here's one way, just for the main logic you're looking for:
Dim in50Block As Boolean
in50Block = False
For Each c In Range("B2:B10000")
If c.Value < 50 And c.Value <> "" Then
Rows(c.Row).Hidden = True
in50Block = False
Else
If in50Block = True And c.Offset(1, 0).Value >= 50 Then
Rows(c.Row).Hidden = True
Else
in50Block = True
End If
End If
Next

Speed up VBA code on extracting relevant rows to new worksheet

I need to copy relevant rows to a new Excel worksheet. The code will loop through each row in the original worksheet and select rows based on relevant countries and products specified in the array into the second worksheet.
Private Sub CommandButton1_Click()
a = Worksheets("worksheet1").Cells(Rows.Count, 2).End(xlUp).Row
Dim countryArray(1 To 17) As Variant
Dim productArray(1 To 17) As Variant
' countryArray(1)= "Australia" and so on...
' productArray(1)= "Product A" and so on...
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 3 To a
For Each j In countryArray
For Each k In productArray
Sheets("worksheet1").Rows(i).Copy Destination:=Sheets("worksheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub
Each time I ran the code, the spreadsheet stopped responding in a matter of minutes. Would appreciate if someone could help me on this, thanks in advance!
Here are some pointers:
Remember to declare all your variables and use Option Explicit at the top of your code
Use With statements to ensure working with right sheet and not implicit activesheet or you may end up with wrong end row count
Only i contributes to the loop so you are making unnecessary loop work
Gather qualifying ranges with Union and copy in one go
Remember to switch back on screen-updating
Code:
Option Explicit
Private Sub CommandButton1_Click()
Dim unionRng As Range, a As Long, i As Long
With Worksheets("worksheet1")
a = .Cells(.Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 3 To a
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, .Cells(i, 1))
Else
Set unionRng = .Cells(i, 1)
End If
Next
With Worksheets("worksheet2")
unionRng.EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Row +1
End With
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

VBa conditional delete loop not working

I am running the following code on a spreadsheet:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
End If
i = i + 1
Loop
There are plenty of entries with not "String" but they do not get deleted.
When I copy this piece of code to a separate sheet, I even get the error "Excel cannot complete this task with available resources. Choose less data or close other applications."
What am I doing wrong that is making this loop not work?
Note: I can't use autofilter because I need to delete rows based on not meeting a condition.
This is the worst way to delete a row. Reasons
You are deleting the rows in a Loop
Your Cells Object are not qualified
Try this.
Co-incidentally I answered a similar question in the MSDN forum as well. Please See THIS
Try this way (UNTESTED)
In the below code I have hardcoded the last row to 100000 unlike as done in the above link.
Sub Sample()
Dim ws As Worksheet
Dim i As Long
Dim delRange As Range
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
For i = 1 To 100000
If .Cells(i, 4).Value <> "String" Then
If delRange Is Nothing Then
Set delRange = .Rows(i)
Else
Set delRange = Union(delRange, .Rows(i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.Delete
End With
End Sub
NOTE: I am assuming that a cell will have values like
String
aaa
bbb
ccc
String
If you have scenarios where the "String" can be in different cases or in between other strings for example
String
aaa
STRING
ccc
dddStringddd
then you will have to take a slightly different approach as shown in that link.
Autofilter code:
Sub QuickCull()
Dim rng1 As Range
Set rng1 = Range([d4], Cells(Rows.Count, "D").End(xlUp))
ActiveSheet.AutoFilterMode = False
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
With rng1
.AutoFilter Field:=1, Criteria1:="<>string"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then _
.Offset(1, 0).Resize(rng1.Rows.Count - 1).Rows.Delete
End With
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
ActiveSheet.AutoFilterMode = False
End Sub
When you want to delete rows its always better to delete from bottom.
Sub DeleteData()
Dim r As Long
Dim Rng As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("sheet1")
Set Rng = .Range(.Range("D1"), .Range("D1").End(xlDown))
For r = Rng.Rows.Count To 1 Step -1
If LCase(Trim(.Cells(r, 4).Value)) <> LCase("string") Then
.Cells(r, 4).EntireRow.Delete
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
This is a basic algorithm mistake.
Imagine your program are on, say, row 10. You delete it. So, row 11 becomes row 10, row 12 becomes 11 and so on. Then you go to row 11, skipping row 10, previous row 11!
This would work:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
Else
i = i + 1
End If
Loop

Resources