I am trying to delete an entire row if the values in row i column 2 and row i column 3 are empty. My for loop only iterates once. Any idea why?
Sub DeleteEm()
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To RowCount
If IsEmpty(Cells(i, 2).Value) = True And IsEmpty(Cells(i, 3).Value) = True Then
Rows(i).EntireRow.Delete
End If
Next i
End Sub
Thank you!
You have made an error which is very common for newbies in VBA. To correct the error you need to change
For i = 2 To RowCount
to
For i = RowCount to 2 Step -1
Your original code is deleting rows within the range over which you are iterating.
Consider what happens when i=4 and you delete the row corresponding to that i. Row 4 is deleted. What was row 5 now becomes row 4 BUT at the Next, i becomes 5 so i is now pointing at what was row 6 in your starting range having skipped over what was previously row 5, because that became row 4.
If you use F8 to step through your code whilst watching your sheet you will see it all happen before your eyes.
Delete Rows With Empty Cells in Two Columns
You could also consider using Application.Union to 'collect' the row ranges in a range and then delete the range in one go.
The Code
Option Explicit
Sub DeleteEm()
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
Dim rng As Range
For i = 2 To RowCount
' Considering 'blank cells = empty cells + ""-cells'.
' Either (For empty cells)...
If IsEmpty(Cells(i, 2)) And IsEmpty(Cells(i, 3)) Then
' ...or (for blank cells)
'If Len(Cells(i, 2)) = 0 And Len(Cells(i, 3)) = 0 Then
If rng Is Nothing Then
Set rng = Rows(i)
Else
Set rng = Union(rng, Rows(i))
End If
End If
Next i
If Not rng Is Nothing Then
rng.Delete
End If
End Sub
Related
i am looking for a solution to my problem. The task is to compare two consecutive rows with each other,in the range from column D1 to the last written cell in Column D. If the value of a consecutive cell is equal to the value of the previous cell , i.e. D2=D1, the macro can go next, else it shall insert a new row between the two values. Since i am fairly new to vba and mostly use information based on online research, i could not find a fitting solution til now. Below you can see a part of what tried.
Sub Macro()
'check rows
Dim a As Long
Dim b As Long, c As Long
a = Cells(Rows.Count, "D").End(xlUp).Row
For b = a To 2 Step -1
c = b - 1
If Cells(b, 4).Value = Cells(c, 4).Value Then
If Cells(b, 4).Value <> Cells(c, 4).Value Then
Rows("c").Select
Selection.Insert Shift:=xlDown
End If
End If
Next b
End Sub
Sub InsertRows()
Dim cl As Range
With ActiveSheet
Set cl = .Cells(.Rows.Count, "D").End(xlUp)
Do Until cl.Row < 2
Set cl = cl.Offset(-1)
If cl.Value <> cl.Offset(1).Value Then cl.Offset(1).EntireRow.Insert
Loop
End With
End Sub
Side note. You can benefit from reading How to avoid using Select in Excel VBA
My worksheet contains blank rows which I want to keep.
However it also contains groups of two blank rows and I want to keep one of them but delete/remove the other one.
END RESULT: sheet contains only single blank rows.
First attachment shows before (highlighted where two blank rows) and second attachment shows desired final result (worksheet only contains single blank rows).
What is the VBA code to achieve this please?
Something like:
select all
identify where two blank rows are and delete one of those rows
Thanks in advance!
In an attempt to improve the question and show my efforts with my own VBA code.... this is what I had got starting with a variable counter of 0 and when it gets to 2 it would delete a row, it sort of works as in it finds and deletes the desired row but it appears to run an infinite loop :(
Sub EmptyRows()
Dim x As Integer
Dim row As Integer
NumRows = ActiveSheet.UsedRange.Rows.Count
' Select cell A2.
Range("A2").Select
row = 0
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
If Application.CountA(ActiveCell.EntireRow) = 0 Then
row = row + 1
End If
ActiveCell.Offset(1, 0).Select
If Application.CountA(ActiveCell.EntireRow) = 0 Then
row = row + 1
End If
If row >= 2 Then
MsgBox "2 Rows!"
ActiveCell.EntireRow.Delete
End If
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
row = 0
Next
End Sub
Try the next code, please. It will check if really whole analyzed rows are empty:
Sub deleteSecondBlankRow()
Dim sh As Worksheet, arr, rngDel As Range, lastR As Long, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.Count).End(xlUp).row
arr = sh.Range("A2:A" & lastR).value
For i = 1 To UBound(arr)
If arr(i, 1) = "" Then
If WorksheetFunction.CountA(rows(i + 1)) = 0 Then
If arr(i + 1, 1) = "" Then
If WorksheetFunction.CountA(rows(i + 2)) = 0 Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i + 2)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i + 2))
End If
End If
End If
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Select
End Sub
The code only selects the rows to be deleted. If you check it and what selected is convenient, you should only replace Select with Delete on the last code line...
I'm attempting to combine 2 rows on my excel spreadsheet into 1 row based on a particular condition being true.
I would like for my vba code to determine whether or not the string of characters in row 2 = the string of characters in row 3.
If they are equal, I would like to copy all of row 3 to column Q in row and then continue on comparing the string values of rows 3 and 4, 4 and 5, etc to the last used row of the spreadsheet.
I've attempted to modify code I've found on Stack Overflow but still can't get my macro to run. Any help with this would be greatly appreciated.
Here's a link to a similar situation I found in Stack Overflow while I was researching how to create my VBA code but I couldn't get the sample code to work for me. Not sure why. vba - excel - if value = next row value then copy another value
Here's part of the Excel worksheet I'm working with. I did have to modify the information on the spreadsheet so that it wouldn't be too wide to paste.
Member Data spreadsheet
Something like:
Public Sub ArrangeData()
Dim i As Long, unionRng As Range, lastRow As Long, counter As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Data") 'change as appropriate
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A1:G" & lastRow).Sort Key1:=.Range("G2:G" & lastRow), Order1:=xlAscending, Header:=xlYes ' 'Sort to ensure in order (and blanks will be at end
For i = 3 To .Range("G1").End(xlDown).Row + 1
If .Cells(i, "G") = .Cells(i - 1, "G") Then
counter = counter + 1
.Cells(i, "A").Resize(1, 6).Copy .Cells(i - counter, .Cells(i - counter, .Columns.Count).End(xlToLeft).Column + 1)
Else
counter = 0
End If
Next i
For i = 3 To .Range("G1").End(xlDown).Row + 1
If IsEmpty(.Cells(i, "H")) Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, .Cells(i, "H"))
Else
Set unionRng = .Cells(i, "H")
End If
End If
Next i
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub
Before:
After:
In my column A I have cells which consists of formatted dates and general formatting. I want to delete rows which are not dates, and I've made this code, but I have to run it multiple times to get it to delete all the rows which aren't dates.
Code:
Sub del_row_not_date()
Dim rng_A_last As Long
Dim i As Integer
rng_A_last = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Debug.Print rng_A_last
For i = 1 To rng_A_last Step 1
If IsDate(Sheet1.Cells(i, 1)) = False Then
Sheet1.Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
Thanks in advance!
Since rows will
Based on this LINK I found this:
a tip about deleting rows based on a condition If you start at the top and work down, every time you delete a row your counter will effectively move to the cell two rows below the row you deleted because the row immediately below the deleted row moves up (i.e. it is not tested at all).
This works :)
Sub del_row_not_date()
Dim rng_A_last As Long
Dim i As Integer
rng_A_last = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Debug.Print rng_A_last
For i = rng_A_last To 1 Step -1
'Debug.Print Cells(i, 1).Value
If IsDate(Sheet1.Cells(i, 1)) = False Then
Sheet1.Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
you could try
Sub del_row_not_date()
With Sheet1
.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow.Delete
End With
End Sub
what above deletes all column "A" not-numbers cells entire row
if you have cells with numbers that are not dates then use:
Option Explicit
Sub del_row_not_date()
Dim i As Integer
With Sheet1
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1 '<--| loop backwards not to loose next row index after deleting the current one
If Not IsDate(.Cells(i, 1)) Then .Cells(i, 1).EntireRow.Delete
Next i
End With
End Sub
I am trying to go through row 6 and from column 1 to 26 and search for the sentence Earned Cumulative Hours. Once that is done then I am trying to go from row 8 to the last row(30 in this case) for the column that has Earned Cumulative Hours in row 6.
Then I am trying to paste the values of the cells from this column to 2 cells left in the same row. But I keep getting errors and the code doesn't work.
Can someone please point me in the right direction ? Thanks
Sub project()
Dim lastrow As Long
Dim i As Long
Dim j As Long
lastrow = Sheets("Progress").Cells(Rows.Count, 26).End(xlUp).Row
For j = 1 To 26
If Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 To lastrow
Cells(i, j).Copy
Cells(i, j).Offset(0, -2).Select
Selection.PasteSpeical Paste:=xlPasteValues
Next i
End If
Next j
End Sub
There are a few problems I can see straight away with your code. Firstly if you are offsetting back two columns .Cells(i, j).Offset(0, -2) then you will be overwriting existing values. If this is what you intend to do then weird but ok.
The next issue is that you have a problem if 'Earned Cumulative Hours' is in Column A. If this is your case Excel will be most unhappy trying to offset two columns to the left and will give an error.
In this case instead of copying and pasting it will be more efficient to set values in one column to the other which you can see in my code. Finally, your Cell references will be valid for the active sheet only. You need to qualify what worksheet you interest in as shown in my code. I normally put this at the start of the code if it is a self contained block.
You could also eliminate the i loop and set ranges of values at a time but we'll save that for next time!
I haven't test this code but it should be fine.
Sub projectawesome()
Dim lastrow as Long, i as Long, j as Long
'Qualify the sheet (assuming its in the activeworkbook)
With Sheets("Progress")
lastrow = .Cells(.Rows.Count, 26).End(xlUp).Row
'I've changed this to column three to prevent offset errors.
For j = 3 to 26
If .Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 to lastrow
'Assuming overwriting data is ok.
'No need to copy and paste
.Cells(i, j - 2).Value = .Cells(i, j).Value
Next i
End If
Next
End With
End Sub
Try this and we can get rid of those selects
Sub project()
Dim lastrow As Long
Dim i As Long
Dim j As Long
lastrow = Sheets("Progress").Cells(Rows.Count, 26).End(xlUp).Row
For j = 1 To 26
If Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 To lastrow
Cells(i, j).Copy
With Cells(i, j)
.Offset(0, -2).PasteSpecial xlPasteValues
End With
Next i ' next row
End If
Next j ' next col
End Sub