I have a VBA code that removes empty cells, allowing for data further down in the column to move up to the top. There are two things that I am looking to fix. One, I don't want to exit the sub, I want to exit the if statement. I've read that you can exit loops, whiles, fors, etc. But not ifs. I don't want to exit the sub because I have more code in my sub. Any suggestions?
I am also having issues adding another line in the code to run if there is already data at the top of the column.
Sub Remove_Empties ()
Dim Last as Long
Dim Mcol as Range
Last = Cells(Rows.Count, "AD").End(xlUp).Row
If Last = 1 Then Exit Sub 'no value only header in row 1
'otherwise
Set Mcol = Range("AD2:AD" & Last) 'contains any value
Application.ScreenUpdating = True
Mcol.SpecialCells(xlCellTypeBlanks).Delete xlUp
Application.ScreenUpdating = True
End Sub
I want it to be able to run the following three scenarios. The first contains data in the row below the header. The second has a couple of empty cells. The third has all empty cells. 1 should not change, 2 should change to match 1's format, and 3 should do nothing. 2 and 3 can be done with the code above, but not 1.
1 2 3
A
B
C A
D B
C
D
Perhaps something like this, noting the following:
You don't need two Application.ScreenUpdating = True lines. You can probably get rid of both.
You need to handle the possibility of no blank cells (column 1).
Sub Remove_Empties()
Dim Last As Long
Last = Cells(Rows.Count, "AD").End(xlUp).Row
If Last <> 1 Then
Dim Mcol As Range
Set Mcol = Range("AD2:AD" & Last) 'contains any value
Dim cellsToDelete As Range
On Error Resume Next
Set cellsToDelete = Mcol.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not cellsToDelete Is Nothing Then
cellsToDelete.Delete shift:=xlUp
End If
End If
End Sub
Or slightly condensed:
Sub Remove_Empties()
Dim Last As Long
Last = Cells(Rows.Count, "AD").End(xlUp).Row
If Last <> 1 Then
On Error Resume Next
Range("AD2:AD" & Last).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0
End If
End Sub
I will just add another answer that you can possibly use in your logic (code) moving forward. Using a simple GoTo statement will break out of an If. For example:
Sub UsingGoTo()
If Last = 1 Then
'do something
GoTo CheckComplete
Else
'if not maybe exit sub?
Exit Sub
End If
CheckComplete:
'continue with program
End Sub
Related
Essentially, when running the below code within one workbook (1 sheet) it completes within an instant. But when using it in my main workbook (couple of sheets, barely any data) it takes a while to complete. How can I optimize the below code?
Sub DeleteBlankRows()
On Error Resume Next
Sheets("Sheet4").Activate
Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Try avoiding the use of an entire column, as well as .Activate:
Sub DeleteBlankRows()
' On Error Resume Next
Dim lastRow As Long
With Sheets("Sheet4")
lastRow = .Cells(Rows.Count, 4).End(xlUp).row
.Range(.Cells(1, 4), .Cells(lastRow, 4)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub
Edit: Commented out the On Error Resume Next
you could try too to stop the automatic calculation and screen update and at the end reenable all.
try this and test too with the other codes
Sub DeleteBlankRows()
Application.ScreenUpdating = False
Application.Calculation = xlManual
On Error Resume Next
Sheets("Sheet4").Activate
Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = true
Application.Calculation = xlAutomatic
End Sub
Good Luck
lastRow = .Cells(Rows.Count, 4).End(xlUp).row
I never use this method for figuring out last row. It takes too long... Basically processing every cell starting from the bottom of the worksheet. Instead, I count the number of cells with values. I use that number to run a for loop which tests to see if there is a value in a given cell and counts until all cells with values are accounted for. Code wise, its more complicated... but in my experience executes more quickly.
kount = Application.WorksheetFunction.CountA(krng) 'Count how many used cells there are
kRow = 1
j = 1
Do Until j = kount + 1 'Do until all used cells are acounted for
If Cells(kRow, l).Value = vbNullString Then 'If current cell is empty skip it
Else
j = j + 1 'If the current cell has a value count up
End If
kRow = kRow + 1 'but go on to the next row either way
Loop
Where kRow is the last row with a value
I have a sheet and the user input Starts in A7 and calculations are inserted with a macro to B7 all the way through I.
I got all that worked out but what i need is: the user is going down typing in data in Column A, lets say they input data Starting from A7, through A11, then skip A12 and type into A13, i want the sheet to automatically move the user's input into A12 so there's never any blank rows IN BETWEEN the data in column A.
Ideally all the data should be in sequence and there shouldn't be any blank rows in between the data entered in column A.
Here is the code i have come up with thus far:
Private Sub worksheet_change(ByVal Target As Range)
Dim r As Integer
Dim c As Integer
1 If Not Intersect(Target, Range("A:C")) Is Nothing Then
If Target.Row >= Range("FormulaRange").Row + 1 Then
If Target.Row <= Range("RowTracker").Value + 1 Then
Dim t
RWS = Target.rows.Count
COLS = Target.Columns.Count
For r = 1 To RWS
For c = 1 To COLS
If Not IsNumeric(Target.rows.Cells(r, c).Value) Then
'Else
MsgBox "Please enter only numeric values."
Application.Undo
'End
Else
If Target.rows.Cells(r, 2) = "" Then Target.rows.Cells(r, 2) = 0
If Target.rows.Cells(r, 3) = "" Then Target.rows.Cells(r, 3) = 0
End If
Next c
Next r
Else
MsgBox "Please enter data in the next available line."
Exit Sub
End If
End If
End If
End Sub
Right now it detects if i skip rows and input arbitrarily in A giving me a warning not to do so but i would love it just took my input and put it back into the next available row in column A.
I thought about doing a Row.Delete but the way the code is set up is keeps detecting the deleted row as skipping cells in A column continuously giving me the error of "Please Enter Data in the next available line."
Key point missing is to prevent a cascade of events as you change the sheet. Use Application.EnableEvent = False to prevent this.
Then deleting rows with blanks will work, something like this
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rw As Long
Dim i As Long, j As Long
On Error GoTo EH
If Not Application.Intersect(Target, Me.Columns("A:C")) Is Nothing Then
rw = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row
' Prevent a cascade of events
Application.EnableEvents = False
For i = rw To 1 Step -1
'Check for blanks in column A, delete row if found
If IsEmpty(Me.Cells(i, 1)) Then
Me.Rows(i).Delete
End If
'check for non numeric data
For j = 1 To 3
If Not IsNumeric(Me.Cells(i, j)) Then
Me.Cells(i, j).ClearContents
End If
'Enter Zeros's
If j > 1 Then
If IsEmpty(Me.Cells(i, j)) Then
Me.Cells(i, j) = 0
End If
End If
Next
Next
End If
EH:
' restore event handling
Application.EnableEvents = True
End Sub
Notes:
The delete rows and check for non numeric/blanks will interact, possibly in ways you don't expect
If user leaves column A blank and enters data into other columns, it will be deleted
I've left out the Named Range checks, as I'm unsure what they are doing. You can reinstate to suit.
Might be better to validate and warn the user before deleting
Something like this will force the user to only stay in the next possible row for column A without being able to enter more information.
This isn't foolproof, but will get you started. You can extend as needed:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Row <> 1 Then
If Len(Target.Offset(-1)) = 0 Then
Target.Offset(-1).Select
End If
End If
End Sub
I am trying to write a code which basically looks at rows 13-33 and deletes the entire row if the cells in Columns B-M are all Blank AND column A is NOT blank.
The first code which I have written below deletes the entire row only if the cell in Column B is blank but I need all the cells in B-M to be blank in order to delete the entire row.
Sub scheduleA()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Schedule A Template").Select
Dim RowstoDelete As Long
x = 33
For RowstoDelete = Cells(x, 2).End(xlUp).Row To 13 Step -1
If (Cells(RowstoDelete, 2).Value = "0") And (Cells(RowstoDelete, 1).Value <> "") Then
Rows(RowstoDelete).Delete Shift:=xlUp
End If
Next RowstoDelete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I tried writing it differently as well in the following code but can't achieve the desire result.
Sub DeleteRows()
Dim i As Integer
For i = 33 To 13 Step -1
If WorksheetFunction.CountA(Range("B" & i, "M" & i)) = 0 And WorksheetFunction.CountA(Range("A" & i)) <> "" Then
Rows(i).EntireRow.Delete
End If
Next i
End Sub
Please help!
Your conditions for row deletion are: column A not blank, columns B to M blank. Then something like this should do the trick:
Sub ScheduleA()
On Error GoTo errHandler
Const TOP_ROW As Long = 13
Const BOTTOM_ROW As Long = 33
Dim rowIndex As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Worksheets("Schedule A Template")
For rowIndex = .Cells(BOTTOM_ROW, "A").End(xlUp).Row To TOP_ROW Step -1
If Not IsEmpty(.Cells(rowIndex, "A").Value2) Then '...column A is not blank.
If Application.WorksheetFunction.CountA(.Range(.Cells(rowIndex, "B"), .Cells(rowIndex, "M"))) = 0 Then '...all cells on row rowIndex from columns B to M are blank.
.Rows(rowIndex).Delete Shift:=xlUp
End If
End If
Next
End With
Cleanup:
On Error Resume Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume Cleanup
End Sub
Note that the .Select is gone; you almost never have to select anything to get the job done. Not relying on the selection will make your code much more robust. In the code above, the With block tells the code within it to refer to the target worksheet whenever an expression starts with a period, such as .Cells.
Also, when turning off ScreenUpdating and Calculation, systematically include error handling to turn them back on. This way, if something goes wrong, your code won't leave Excel in an undesirable state.
Finally, instead of referring to worksheets by their tab's name (as seen from Excel), you can refer to them directly using their CodeName, as seen from the VBA editor, in the Properties window, under the worksheet's (Name) property (press Ctrl+R to show the Project Explorer, click on the worksheet under the Microsoft Excel Objects node, then press F4 to display the Properties window). You can change this value; I'd typically change it to shtScheduleATemplate. Then, the With line could be re-written as:
With shtScheduleATemplate
...which would still work even after you changed the worksheet's name from Excel.
EDIT: in your question's code, you are checking column B when determining at which bottom row index to start the loop. However, by doing so, you may miss some rows that should be deleted. I've changed my answer to check within column A instead:
For rowIndex = .Cells(BOTTOM_ROW, "A").End(xlUp).Row To TOP_ROW Step -1
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
I have read a number of posts about hiding rows in Excel, and they all helped me with the hiding, but I still don't seem to find any solutions for why it will not UNHIDE.
I am using the following code:
Private Sub Worksheet_Calculate()
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "D").End(xlUp).Row
On Error Resume Next
For Each c In Range("D116:D" & LastRow)
If c.Value = 0 Then
c.EntireRow.Hidden = True
ElseIf c.Value > 0 Then
c.EntireRow.Hidden = False
End If
Next
On Error GoTo 0
Application.EnableEvents = True
End Sub
If I start with some 1 and some 0 values, then the code successfully hides the rows with value 0, AND also continues to be active, ensuring that any values I later change from 1 to 0 are automatically hidden.
However, the values that were initially 0, once changed to 1, will not UNHIDE automatically. This is a big problem because I intend to start with all zero values, and then unhide rows as these values change to 1 or greater than 1. It's worth of note that these values in column D are references to somewhere else in the same spreadsheet (just for instance =N100), so that I can control the values even when the rows are hidden. I didn't think the use of a formula was a problem because it can still respond to dynamic changes to HIDE (when changed from 1 to 0), just not to UNHIDE.
Any suggestions?
Thanks to all who helped. Thanks to Ads help I created a macro, and from that code I got the line that I was missing: Activate. The code now works as:
Private Sub Worksheet_Calculate()
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "D").End(xlUp).Row
On Error Resume Next
For Each c In Range("D116:D" & LastRow)
If c.Value = 0 Then
c.EntireRow.Hidden = True
ElseIf c.Value > 0 Then
c.Activate
c.EntireRow.Hidden = False
End If
Next
On Error GoTo 0
Application.EnableEvents = True
End Sub
I'm not sure exactly how to show a row in VBA, what you have looks right to show a row. But when I was ever unsure how to do something, I would record a macro to do what I wanted to achieve and then just review the code that excel generates.