This seems like it should be a fairly simple task but I can't seem to get it to work- I just want a simple macro that will loop through all the cells in my worksheet. If the cell is equal to zero (or blank for kicks), then just delete it, moving the other cells in the column up one.
I got nowhere trying to do it on the whole document, so I tried to do it on a single column :
Sub Macro6()
'
' Macro6 Macro
'
' Keyboard Shortcut: Ctrl+q
'
For i = 81 To 1 Step -1
If Range("A" & i) = "0" Then Range("A" & i).Delete
Next i
End Sub
I don't want to delete any rows, just the individual cells if they have value 0.
But evidently still getting nowhere.
Select the range to delete blanks within. Home > Editing – Find & Select, Go To Special, Blanks, OK, select within array, Delete…, Shift cells up, OK.
To apply the same process to cells containing 0 select range to delete 0s within and start (ie before above) by replacing these with nothing:
Home > Editing, Find & Select, enter 0 in Find what:, check Match entire cell contents and ensure Replace with: is empty, Replace All.
This small macro will delete both blanks and zeros:
Sub dural()
Dim rKill As Range, r As Range
Set rKill = Nothing
For Each r In ActiveSheet.UsedRange
If r.Value = 0 Or r.Value = "" Then
If rKill Is Nothing Then
Set rKill = r
Else
Set rKill = Union(rKill, r)
End If
End If
Next
If rKill Is Nothing Then
Else
rKill.Delete Shift:=xlUp
End If
End Sub
As pnuts pointed out, this can be a little slow. The following might be a little quicker:
Sub dural2()
With Cells
.Replace "0", ""
.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
End Sub
Related
I am using form control buttons to add and delete the rows above the button. There are several sections per worksheet, hence the find function.
Adding the row has no issue. The question is about deleting rows... to a limit.
The Code:
Sub Button4_Click()
ActiveSheet.Unprotect
Dim Found As Range
Set Found = Columns("B").EntireRow.Find(what:=" Remove Row ", LookIn:=xlValues, Lookat:=xlWhole)
If Not Found Is Nothing Then
Rows(Found.Row - 1).EntireRow.Delete
End If
ActiveSheet.Protect
End Sub
The problem is that I don't want the end user to delete rows containing headings. I'd like to add something that will stop the sub if the row above the Found.Row contains the text "Travel Expenditures".
It's a "if" I suspect, but I'm stuck.
Any suggestions?
(Novice User)
You were on the right track. A couple comments:
Do you need all the whitespace around "Remove Row"?
Columns("B").EntireRow is the entire sheet - I'm assuming you wanted just Columns("B").
I revised your code based on these 2 issues.
Sub ConditionalDelete()
Dim Found As Range, Found2 As Range
ActiveSheet.Unprotect
Set Found = Columns("B").Find(what:="*Remove Row*", LookIn:=xlValues, Lookat:=xlWhole)
If Not Found Is Nothing Then
Set Found2 = Rows(Found.Row - 1).Find(what:="Travel Expenditures")
If Found2 Is Nothing Then
Rows(Found.Row - 1).Delete
End If
End If
ActiveSheet.Protect
End Sub
you could Intersect rows and column with ActiveSheet.UsedRange to limit scanned ranges
and here's a code with Application.Match method, which I believe is faster than Range.Find(), but is case insensitive:
Sub Button4_Click()
Dim iRow As Variant
iRow = Application.Match(" Remove Row ", Intersect(ActiveSheet.UsedRange, Columns("B")), 0)
If Not IsError(iRow) Then
If IsError(Application.Match("Travel Expenditures", Intersect(ActiveSheet.UsedRange, Rows(iRow - 1).EntireRow), 0)) Then
ActiveSheet.Unprotect
Rows(iRow - 1).Delete
ActiveSheet.Protect
End If
End If
End Sub
I have an excel file which includes a lot of rows. Every second rows are slipped. How can I fix these slipped rows by VBA?
I have attached a little template:
And what can I do if the blank cells are there on the right side?
Here is the VBA version of my comment with shift to left:
Range("A:A").SpecialCells(xlCellTypeBlanks).Delete xlShiftToLeft
There is no shift to right delete, but there are few ways around it depending on the layout. A more general approach can be to move the blank cells selection to the left and use insert shift to right, but I am not sure how to do that without VBA.
For example, selecting the blank cells in column F and inserting the corresponding cells on the same rows in column A:
Intersect(Range("A:A"), Range("F:F").SpecialCells(xlCellTypeBlanks).EntireRow).Insert xlShiftToRight
A more general approach for more random blank areas is to shift each row separately:
With ActiveCell.Worksheet.UsedRange ' or change to a different range
.SpecialCells(xlCellTypeBlanks).Delete xlShiftToLeft ' to shift all non-blank cells to the left
For Each area In .SpecialCells(xlCellTypeBlanks).Areas
area.Offset(, .Column - area.Column).Insert Shift:=xlToRight
Next
End With
Assumes data in columns A to F
Sub Main()
Dim rng As Range, cl As Range
Set rng = Range("B1:B" & Range("B1").End(xlDown).Row)
For Each cl In rng
If cl.Offset(0, -1) = vbNullString Then
Range(Cells(cl.Row, cl.Column), Cells(cl.Row, 6)).Cut Destination:=cl.Offset(0, -1)
End If
Next cl
End Sub
try this:
Sub slipp_fix()
Set ww = Application.Selection
Set ww = Application.InputBox("Select first col of table", xTitleId, ww.Address, Type:=8)
For Each C In ww
If C.Value = "" Then
C.Select
Selection.Delete Shift:=xlToLeft
End If
Next
end sub
I am creating a Master Schedule for work and am trying to display information so it is very intuitive to the user.
So... we would like to be able to Highlight Cells J4:L4 when a date is entered in Cell K4. Then, we want to loop it for Rows 4 through 2500 and Columns M:0, P:R, S:U, etc.... I have the following Macro written but it is only highlighting the first Row. Can someone point me in the right direction?
Sub Highlight()
'
' Highlight Macro
'
' Keyboard Shortcut: Ctrl+Shift+R
'
Dim kRange As Range, k As Integer, aaaFormat As FormatCondition
If ActiveSheet.Name <> Sheet1.Name Then Exit Sub
For k = 4 To 2500
Set kRange = Range("=$J4:$L4")
If kRange.FormatConditions.Count <> 0 Then
kRange.FormatConditions.Delete
Else
Set aaaFormat = kRange.FormatConditions.Add(xlExpression, xlFormula, "=$K4<>0")
aaaFormat.Interior.Color = 15773696
End If
Next k
End Sub
While you are cycling through the loop, you need to adjust the range the CF rule will govern as well as the formula that determines its outcome.
'this,
Set kRange = Range("$J4:$L4")
'becomes,
Set kRange = Range("$J"& k & ":$L"& k)
'and this,
Set aaaFormat = kRange.FormatConditions.Add(xlExpression, xlFormula, "=$K4<>0")
'becomes,
Set aaaFormat = kRange.FormatConditions.Add(xlExpression, xlFormula, "=$K" & k & "<>0")
However, since you've already made the row relative and the column absolute, you can simply write the CF to the entire range.
Sub Highlight()
' Highlight Macro
' Keyboard Shortcut: Ctrl+Shift+R
With Sheet1.Range("J4:L2500")
.FormatConditions.Delete
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=$K4<>0")
.Interior.Color = 15773696
End With
End With
End Sub
I need to search through a group of email addresses in column K and delete any rows with #noemail.com. Below is my code attempt. It was previously working but would only delete one row at a time forcing me to run the macro multiple times.
`Sub Prospects()
'
' Prospects Macro
'
' Delete rows with #noemail.com
Dim rng As Range
Dim row As Range
Dim ContainWord As String
' Select range in column K
Range("K2").Select
Range(Selection, Selection.End(xlDown)).Select
Set rng = Selection
' Set noemail as word to search for
ContainWord = "noemail"
' Loop through each cell in range, test cell contents and clear noemail.com rows
For Each row In rng.Cells
If Not row.Find(ContainWord) Is Nothing Then rng.EntireRow.Delete
Next row
Range("B2").Select
End Sub
The problem is with this line:
If Not row.Find(ContainWord) Is Nothing Then rng.EntireRow.Delete
Specifically the last part: rng.EntireRow.Delete. rng is the entire selection and not just those that are filtered. You are going cell by cell then when it finds one that returns True it deletes the top row of the rng
By changing rng to row you should get the desired effect., like this:
If Not row.Find(ContainWord) Is Nothing Then row.EntireRow.Delete
edit to deal with loop:
The problem is that when it deletes a line it moves to the next cell. If there is a "noemail" in the line right below the one that is deleted it moves that one into the row you just tested and skips it.
Try this:
Sub Prospects()
' Delete rows with #noemail.com
Dim ContainWord As String
Dim i As Integer
i = 2 ' i is a counter
' Set noemail as word to search for
ContainWord = "noemail"
' Loop through each cell in column K, test cell contents and clear noemail.com rows
Do While Range("K" & i) <> ""
If Not Range("K" & i).Find(ContainWord) Is Nothing Then
Range("K" & i).EntireRow.Delete
Else
i = i + 1
End If
Loop
Range("B2").Select
End Sub`
This will stay on the same row deleting bad addresses till it encounters a good address then move to the next.
Can anyone walk me through how to write a script to delete the entire row if a cell in column D = "" on sheet 3 in range D13:D40.
Also, how to prevent the user from accidentally running the script again once those cells in the range are already deleted and other cells are now on the D13:D40 range?
Solution: This is working for me:
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.ActiveSheet.Range("D13:D40")
With rng
' Loop through all cells of the range
' Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
' Since cell is empty, delete the whole row
.Item(i).EntireRow.Delete
End If
Next i
End With
End Sub
Explanation: Run a for loop through all cells in your Range in column D and delete the entire row if the cell value is empty. Important: When looping through rows and deleting some of them based on their content, you need to loop backwards, not forward. If you go forward and you delete a row, all subsequent rows get a different row number (-1). And if you have two empty cells next to each other, only the row of the first one will be deleted because the second one is moved one row up but the loop will continue at the next line.
No need for loops:
Sub SO()
Static alreadyRan As Integer
restart:
If Not CBool(alreadyRan) Then
With Sheets("Sheet3")
With .Range("D13:D40")
.AutoFilter 1, "="
With .SpecialCells(xlCellTypeVisible)
If .Areas.Count > 1 Then
.EntireRow.Delete
alreadyRan = alreadyRan + 1
End If
End With
End With
.AutoFilterMode = False
End With
Else
If MsgBox("procedure has already been run, do you wish to continue anyway?", vbYesNo) = vbYes Then
alreadyRan = 0
GoTo restart:
End If
End If
End Sub
Use AutoFilter to find blank cells, and then use SpecialCells to remove the results. Uses a Static variable to keep track of when the procedure has been run.
Here's my take on it. See the comments in the code for what happens along the way.
Sub deleterow()
' First declare the variables you are going to use in the sub
Dim i As Long, safety_net As Long
' Loop through the row-numbers you want to change.
For i = 13 To 40 Step 1
' While the value in the cell we are currently examining = "", we delete the row we are on
' To avoid an infinite loop, we add a "safety-net", to ensure that we never loop more than 100 times
While Worksheets("Sheet3").Range("D" & CStr(i)).Value = "" And safety_net < 100
' Delete the row of the current cell we are examining
Worksheets("Sheet3").Range("D" & CStr(i)).EntireRow.Delete
' Increase the loop-counter
safety_net = safety_net + 1
Wend
' Reset the loop-counter
safety_net = 0
' Move back to the top of the loop, incrementing i by the value specified in step. Default value is 1.
Next i
End Sub
To prevent a user from running the code by accident, I'd probably just add Option Private Module at the top of the module, and password-protect the VBA-project, but then again it's not that easy to run it by accident in the first place.
This code executes via a button on the sheet that, once run, removes the button from the worksheet so it cannot be run again.
Sub DeleteBlanks()
Dim rw As Integer, buttonID As String
buttonID = Application.Caller
For rw = 40 To 13 Step -1
If Range("D" & rw) = "" Then
Range("D" & rw).EntireRow.Delete
End If
Next rw
ActiveSheet.Buttons(buttonID).Delete
End Sub
You'll need to add a button to your spreadsheet and assign the macro to it.
There is no need for loops or filters to find the blank cells in the specified Range. The Range.SpecialCells property can be used to find any blank cells in the Range coupled with the Range.EntireRow property to delete these. To preserve the run state, the code adds a Comment to the first cell in the range. This will preserve the run state even if the Workbook is closed (assuming that it has been saved).
Sub DeleteEmpty()
Dim ws As Excel.Worksheet
Set ws = ActiveSheet ' change this as is appropriate
Dim sourceRange As Excel.Range
Set sourceRange = ws.Range("d13:d40")
Dim cmnt As Excel.Comment
Set cmnt = sourceRange.Cells(1, 1).Comment
If Not cmnt Is Nothing Then
If cmnt.Text = "Deleted" Then
If MsgBox("Do you wish to continue with delete?", vbYesNo, "Already deleted!") = vbNo Then
Exit Sub
End If
End If
End If
Dim deletedThese As Excel.Range
On Error Resume Next
' the next line will throw an error if no blanks cells found
' hence the 'Resume Next'
Set deletedThese = sourceRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not deletedThese Is Nothing Then
deletedThese.EntireRow.Delete
End If
' for preserving run state
If cmnt Is Nothing Then Set cmnt = sourceRange.Cells(1, 1).AddComment
cmnt.Text "Deleted"
cmnt.Visible = False
End Sub
I've recently had to write something similar to this. I'm not sure that the code below is terribly professional, as it involves storing a value in cell J1 (obviously this can be changed), but it will do the job you require. I hope this helps:
Sub ColD()
Dim irow As long
Dim strCol As String
Sheets("sheet2").Activate
If Cells(1, 10) = "" Then
lrun = " Yesterday."
Else: lrun = Cells(1, 10)
End If
MsgBox "This script was last run: " & lrun & " Are you sure you wish to continue?", vbYesNo
If vbYes Then
For irow = 40 To 13 step -1
strCol = Cells(irow, 4).Value
If strCol = "" Then
Cells(irow, 4).EntireRow.Delete
End If
Next
lrun = Now()
Cells(1, 10) = lrun
Else: Exit Sub
End If
End Sub