I would like to delete entire rows when cells are blank in column B, but I want to skip some of the cells. I managed to work out a code for the first part, but I want to skip two rows and then let the code delete the next part.
First part is B4:B13 and the next is B16:B27
Try the next code, please. It uses a discontinuous range (as you need) and delete all the rows at the end of the code, at once. Being very fast, even on big ranges:
Sub testDeleteRowsDiscontinuousRange()
Dim sh As Worksheet, lastRow As Long, C As Range, rngDel As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your necessary sheet
lastRow = sh.Range("B" & Rows.count).End(xlUp).Row
Set rng = sh.Range("B4:B13,B16:B27")
For Each C In rng.cells
If C.Value = "" Then
If rngDel Is Nothing Then
Set rngDel = C
Else
Set rngDel = Union(rngDel, C)
End If
End If
Next C
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub
Related
Looking for a conditional looping, perhaps Do Until or some similar that will run through the range of cells (say A3:A13) and if there’s a blank cell within that range there would be a command that will automatically hide entire row where the blank cell sits.(if the blank cell is A5 this mean entire row 5 would be hidden) The command will run through until all the the blank cells are detected and automatically all the rows associated with blank cells are hidden until it reach the end of the range A13. Any suggestions kindly welcome.
You can try something like this. First we loop through the range("A" & LRow) it will map all the blank cells and hide all in one go.
Option Explicit
Sub HideRows()
Dim ws As Worksheet
Dim LRow As Long
Dim HideRng As Range
Dim i As Long
Set ws = ActiveSheet
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To LRow
If Len(Trim(.Range("A" & i).value)) = 0 Then
If HideRng Is Nothing Then
Set HideRng = .Rows(i)
Else
Set HideRng = Union(HideRng, .Rows(i))
End If
End If
Next i
If Not HideRng Is Nothing Then HideRng.EntireRow.Hidden = True
Set HideRng = Nothing
End With
End Sub
I have a range of data, with CASE ID's in Column A, and Issues (1 through 10, or Columns B through K) in Columns B onwards.
Once certain issues are ruled out as 'normal', they would be removed from the Issues sheet based on their respective column. For ex: CASE ID #25, Issue 4 is ruled OK, then it would be deleted from Row 25, Column 5 (or Column E) but the CASE ID would remain.
The goal is that by doing this check after the fact, it may leave certain rows entirely blank, from Column B onwards (since the CASE ID would already be there.)
My code doesn't function successfully. Once run, it highlights several rows that are not entirely blank in the target range.
I'm trying to pinpoint rows in the range B2:P & lastrow where the entire row is blank, and then highlight these rows and subsequently delete them.
Code:
Public Sub EmptyRows()
lastrow = Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).row
On Error Resume Next
Sheets("Issues").Activate
For Each rng In Range("B2:P" & lastrow).Columns
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Interior.ColorIndex = 11
'rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next rng
Application.ScreenUpdating = True
End Sub
The purpose of first highlighting is to test the code works. If successful, they would be deleted entirely.
Your description says Columns B through K, but your code has B through P...
You can do it like this (adjust resize for actual columns involved):
Public Sub EmptyRows()
Dim lastRow As Long, sht As Worksheet, c As Range, rngDel As Range
Set sht = Sheets("Issues")
For Each c In sht.Range(sht.Range("A2"), sht.Cells(Rows.Count, 1).End(xlUp)).Cells
If Application.CountA(c.Offset(0, 1).Resize(1, 10)) = 0 Then
'build range to delete
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
'anything to flag/delete ?
If Not rngDel Is Nothing Then
rngDel.EntireRow.Interior.ColorIndex = 11
'rngDel.EntireRow.Delete '<< uncomment after testing
End If
End Sub
Once run, it highlights several rows that are not entirely blank in the target range.
This is because you are selecting all blanks, instead of only rows where the entire row is blank.
See the code below
Public Sub EmptyRows()
With Sheets("Issues")
lastrow = .Cells(Rows.Count, "A").End(xlUp).row
Dim rng as Range
For Each rng In .Range("B2:B" & lastrow)
Dim blankCount as Integer
blankCount = Application.WorksheetFunction.CountA(rng.Resize(1,.Range("B:P").Columns.Count))
If blankCount = .Range("B" & lastRow & ":P" & lastRow).Columns.Count Then
Dim store as Range
If store Is Nothing Then Set store = rng Else: Set store = Union(rng, store)
End If
Next rng
End With
store.EntireRow.Interior.ColorIndex = 11
'store.EntireRow.Delete
End Sub
Gathering the ranges first and then modified them (changing color or deleting) will help to execute the code faster.
Here is another approach, using CountA
For Each cell In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Dim rng As Range
Set rng = Range("A" & cell.Row & ":" & "P" & cell.Row)
If Application.WorksheetFunction.CountA(rng) = 1 Then
rng.EntireRow.Interior.ColorIndex = 11
End If
Next cell
I found a procedure to highlight merged cells in an active sheet:
I tried a ActiveCell.EntireRow.Delete statement to delete the row that is currently iterated over.
Sub DeleteRows()
Dim x As Range
For Each x In ActiveSheet.UsedRange
If x.MergeCells Then
x.Interior.ColorIndex = 8
ActiveCell.EntireRow.Delete
End If
Next
End Sub
I don't care about highlighting the merged cells. The goal is to delete any row that has a merged cell.
Find out all merged cell ranges, club them and delete in one go.
Sub DeleteRows()
Dim x As Range
Dim rngDelete As Range
For Each x In ActiveSheet.UsedRange
If x.MergeCells Then
If rngDelete Is Nothing Then
Set rngDelete = x
Else
Set rngDelete = Union(rngDelete, x)
End If
End If
Next
If Not rngDelete Is Nothing Then
rngDelete.EntireRow.Delete
End If
End Sub
When deleting rows, always delete from the bottom up or a) you risk deleting the next cell you want to examine and b) you risk skipping over a row that comes up to take the place of a deleted row.
Sub DeleteRows()
Dim r as long, c as long
with ActiveSheet.UsedRange
'work backwards through the rows
For r = .rows.count to 1 step -1
'work forwards through the columns
For c = 1 to .columns.count
If .cells(r, c).MergeCells Then
'once a merged cell is found, delete then go immediately to the next row
.cells(r, c).EntireRow.Delete
exit for
End If
next c
Next r
end with
End Sub
A quick way to do this is to find all the merged cells then delete them in one go: a good way to do this is to use a range.find using a cells 'format' as merged then combine the found ranges
The following code loops through merged ranges and creates a union then selects the entire rows
Sub SelectMerge()
Dim rng As Range, rngUnion As Range, Test As Range
Dim ws As Worksheet: Set ws = ActiveSheet
With Application.FindFormat
.Clear
.MergeCells = True
End With
With ws.UsedRange
Set rng = .Find("", SearchFormat:=True)
Do
If Not rngUnion Is Nothing Then Set rngUnion = Application.Union(rng, rngUnion)
If rngUnion Is Nothing Then Set rngUnion = rng
If rng Is Nothing Then Exit Do
Set rng = .Find("", After:=rng, SearchFormat:=True)
Loop While Application.Intersect(rng, rngUnion) Is Nothing
End With
If Not rngUnion Is Nothing Then rngUnion.EntireRow.Select 'rngUnion.EntireRow.Delete
End Sub
I have a sheet that has a List box when that is selected codes appear. If a code is selected, excel copies the data from a worksheet (with the same code) into a quotation sheet.
If I make a change and select another code in the same list box, I need excel to go and find the old data and delete it in the Quotation sheet.
Public Sub delete_selected_rows()
Dim rng1 As Range, rng2 As Range, rngToDel As Range, c As Range
Dim lastRow As Long
With Worksheets("Q")
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rng1 = .Range("B1:B" & lastRow)
End With
Set rng2 = Worksheets("SO").Range("D35")
For Each c In rng1
If Not IsError(Application.Match(c.Value, rng2, 0)) Then
'if value from rng1 is found in rng2 then remember this cell for deleting
If rngToDel Is Nothing Then
Set rngToDel = c
Else
Set rngToDel = Union(rngToDel, c)
End If
End If
Next c
If Not rngToDel Is Nothing Then rngToDel.CurrentRegion.Delete
End Sub
How can I get CurrentRegion to count an extra 30 rows the delete?
VBA's ISERROR won't catch the error caused by a failed MATCH worksheet function. You need to construct that part differently.
Public Sub delete_selected_rows()
Dim rng1 As Range, rng2 As Range, rngToDel As Range, c As Range
Dim lastRow As Long
Dim R As Long
With Worksheets("Q")
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rng1 = .Range("B1:B" & lastRow)
End With
Set rng2 = Worksheets("SO").Range("D35")
For Each c In rng1
On Error Resume Next
R = 0
R = WorksheetFunction.Match(c.Value, rng2, 0)
On Error GoTo 0
If R Then
'if value from rng1 is found in rng2 then remember this cell for deleting
' R is the row number in rng2 where a match was found
' since rng2 is a single cell, R would always be 1, if found
' If rng2 = D35 MATCH be an overkill. Why not simply compare?
Else
If rngToDel Is Nothing Then
Set rngToDel = c
Else
Set rngToDel = Union(rngToDel, c)
End If
End If
Next c
If Not rngToDel Is Nothing Then rngToDel.CurrentRegion.Delete
End Sub
Please observe my comments about rng2. Could there be some mistake? What does SO.D35 contain? If it contains a string of values one of which might be the one you look for MATCH is the wrong function to use.
It seems that you intend to put all items to be deleted on a spike and delete them in one go at the end. I'm not sure that is possible, and it's getting late for me. The more common approach would be to delete one row at a time, as you find them, because once you delete a row all row numbers below that row will change. You can run the entire code with ScreenUpdating turned off and set Application.ScreenUpdating = True after all the deleting has been done.
In various places in column E of spreadsheet "Review" I have variables that start with the word "Sustainability:" (e.g., Sustainability: a, Sustainability:B"). Each time it finds one. I want it to copy the cell that is in the same row but two columns to the right. Then I want it to paste into a different sheet (SPSE Tran), starting at B63. Each time it pastes, the destination needs to offset by 1 row so it can paste down until it finds no more "Sustainability:". The code below is a start to this but I am stuck.
The second thing I need it to do (which I don't even know where to start) is to only iterate doing this until it finds a row that says "ONLY FOR TRANSITIONS". This leads into a new section that also includes "Sustainability:" but I don't want it to copy from there.
Thank you!
Sub SubmitData()
Dim RngA As Range
Dim FirstAd As String
Dim DestAd As Range
With Sheets("Review").Range("E:E")
Set RngA = .Find(What:="Sustainability:", lookat:=xlPart)
Set DestAd = Range("B63")
If Not RngA Is Nothing Then
FirstAd = RngA.Address
Do
Range(Cell, Cell.Offset(0, 2)).Copy _
Destination:=Sheets("SPSE Tran").Range(DestAd)
Set RngA = .FindNext(RngA)
Set DestAd = DestAd.Offset(0, 1)
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd
End If
End With
End Sub
Here's your code revamped to use a filter instead of a find loop, and then it gets all the results and copies them to the destination at once:
Sub SubmitData()
Dim ws As Worksheet
Dim rngDest As Range
Dim rngStop As Range
With Sheets("SPSE Tran")
Set rngDest = .Cells(Rows.Count, "B").End(xlUp)
If rngDest.Row < 63 Then Set rngDest = .Range("B63")
End With
Set ws = Sheets("Review")
Set rngStop = ws.Columns("A").Find("ONLY FOR TRANSITIONS", , xlValues, xlPart)
With ws.Range("E1:E" & rngStop.Row)
.AutoFilter 1, "Sustainability:*"
.Offset(1, 2).Copy rngDest
.AutoFilter
End With
End Sub
How about (untested):
RngB = where you find "ONLY FOR TRANSITIONS"
RngBRow = RngB.Row
then change your Loop While .. to
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd And RngA.Row < RngBRow