This question already has answers here:
Excel VBA - Delete empty rows
(9 answers)
Closed 5 years ago.
I checked the search function, but could not find any answer to my issue.
What I want is VBA to check a specific range for 200+ rows whether these are entirely empty and if so, to delete these and shift up cells.
Sub delete_empty_cells2()
Dim k As Integer
Dim r As Range
For k = 4 To 260
Set r = Range("AAk:AFk")
If r.Value = "" Then
r.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
End If
Next k
End Sub
Now obviously, the code is wrong. I'm not really used to VBA yet and don't know all commands / objects. Is there a way to tell VBA that the range is variable (it should check all ranges, e.g. starting by checking AA4:AF4).
Thanks in advance!
Zahbi
You should go backwards in your loop and look at the code below to see how to use k variable accordingly. If you loop forwards, when you delete a row, you should decrease this number from your loop variable and it is a lot of work, plus confusing.
Try this:
Sub delete_empty_cells2()
Dim k As Long
Dim r As Range
For k = 260 To 4 Step -1
Set r = Range("AA" & k & ":AF" & k)
If Application.WorksheetFunction.CountA(r) = 0 Then
Rows(k).EntireRow.Delete
End If
Next k
End Sub
Here's one way to do it. You don't actually have to delete anything until right at the end -- it's much quicker.
Sub delete_empty_cells2()
Dim rng As Range, fullRow As Range, populatedRange As Range, emptyRange As Range
Set rng = Sheet1.Range("AA4:AF260")
For Each fullRow In rng.Rows
Set populatedRange = fullRow.Find("*")
If populatedRange Is Nothing Then
If emptyRange Is Nothing Then
Set emptyRange = fullRow
Else
Set emptyRange = Union(emptyRange, fullRow)
End If
End If
Next fullRow
If Not emptyRange Is Nothing Then emptyRange.Delete
End Sub
Related
Hi I need to check all data in column for spellings and abbreviation.
Here's my code:
Sub ColorMispelledCells()
For Each cl In ActiveSheet.UsedRange
If Not Application.CheckSpelling(Word:=cl.Text) Then _
cl.Interior.ColorIndex = 28
Next cl
End Sub
Anyway I can alter this to make it a column based checking and not cell and not hightlight the cell but instead add a note to the next column that the word is wrong spelling or abbreviated?
You would change the loop to a for loop to go through a single column. You would need to do more specifics for what the message should be, if it's spelling, abbreviated, etc.
Dim i as Long, j as Long, LR as Long
j = 1 'Setting this up for Column A, aka Column 1
LR = Cells( Rows.Count, j).End(xlUp).Row 'Assumes contiguous column j
For i = 1 to LR
If Application.CheckSpelling(word:=Cells(i,j).Value)=False Then
Cells(i,j+1).Value = "SpellCheck Error!"
End If
Next i
First, change your routine that is works with any Range.
Sub ColorMispelledCells(r As Range)
Dim c As Range
For Each c In r
if VarType(c.value2) = vbString then
If Not Application.CheckSpelling(c.Value2) Then
c.Interior.ColorIndex = 28
Else
c.Interior.ColorIndex = 0
End If
End If
Next
End Sub
Variant, not coloring but write a text in the cell to the right - but note that this will overwrite whatever content is in that cell.
c.Offset(0, 1) = "You have misspelled something..."
Then, add a sub for the button - this will spell check all cells in use (but note that this may take quite some time.
sub ButtonPressed()
ColorMispelledCells(activesheet.usedRange)
end sub
I'm very new to VBA (~4 days new) and have tried to solve this issue in my usual method, through reading lots of different posts on resources like this and experimenting, but have not been able to quite get the hang of it. I hope you fine folks are willing to point out where I'm going wrong with this. I've looked at a lot (all?) of the threads with similar issues but haven't been able to cobble together a solution for myself from them. I hope you'll forgive this if it has already been answered somewhere else.
Context:
I've got a spreadsheet with items in rows 5-713 down column B (merged up to cell J) where for each date (Columns K-SP) the item is scored either a 1 or a 0. My goal is to create a list at the bottom of the worksheet that contains all items which have gone from 1 to 0. To start, I've simply been trying to get my "generate list" button to copy all rows with a 0 in them to the bottom, figuring I would tweak it later to do exactly what I wanted. I've tried several things and gotten several different errors.
Worksheet Sample for a visual of what I'm talking about.
I've gone through several different attempts and have had limited success with each, usually getting a different error every time. I've had "method 'range of object' _Worksheet failed", "object required", "type mismatch", "out of memory", and a few others. I'm sure I'm simply not grasping some of the basic syntax, which is causing some problems.
Here is the latest batch of code, giving me the error 'type mismatch'. I've also tried having 'todo' be string but that just shoots out 'object required'
Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim y As Integer, z As Integer, todo As Range
Set todo = ThisWorkbook.ActiveSheet.Range(Cells(5, 2), Cells(713, 510))
y = 5
z = 714
With todo
Do
If todo.Rows(y).Value = 0 Then
todo.Copy Range(Cells(z, 2))
y = y + 1
z = z + 1
End If
Loop Until y = 708
End With
Application.ScreenUpdating = True
End Sub
Another attempt I thought was promising was the following, but it gives me 'out of memory'.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim y As Integer, z As Integer
y = 5
z = 714
Do
If Range("By:SPy").Value = 0 Then
Range("By:SPy").Copy Range("Bz")
y = y + 1
z = z + 1
End If
Loop Until y = 708
Application.ScreenUpdating = True
End Sub
Just to reiterate, the code attempts I've posted were simply to get any row containing 0's to the bottom of the spreadsheet, however, if there's a way define the criteria to search for 1's that turn to 0's, that would be amazing! Also, I'm not sure how to differentiate a 0 in the actual data and a zero in the item name (for example, it would not be great to have 'Item 10' go into the list just because 10 is a 1 with a 0 after it).
Any help to figure out this first step, or even how to have it scan for 1's that turn to 0's would be wonderfully appreciated. I'm sure I'm missing something simple and hope you guys can forgive my ignorance.
Thanks!
This looks through the data and copies it down below the last row of the data. It is assuming there is nothing below the data. It also only looks for zeros after it finds a 1.
Sub findValueChange()
Dim lastRow As Long, copyRow As Long, lastCol As Long
Dim myCell As Range, myRange As Range, dataCell As Range, data As Range
Dim hasOne As Boolean, switchToZero As Boolean
Dim dataSht As Worksheet
Set dataSht = Sheets("Sheet1") '<---- change for whatever your sheet name is
'Get the last row and column of the sheet
lastRow = dataSht.Cells(Rows.Count, 2).End(xlUp).row
lastCol = dataSht.Cells(5, Columns.Count).End(xlToLeft).Column
'Where we are copying the rows to (2 after last row initially)
copyRow = lastRow + 2
'Set the range of the items to loop through
With dataSht
Set myRange = .Range(.Cells(5, 2), .Cells(lastRow, 2))
End With
'start looping through the items
For Each myCell In myRange
hasOne = False 'This and the one following are just flags for logic
switchToZero = False
With dataSht
'Get the range of the data (1's and/or 0's in the row we are looking at
Set data = .Range(.Cells(myCell.row, 11), .Cells(myCell.row, lastCol))
End With
'loop through (from left to right) the binary data
For Each dataCell In data
'See if we have encountered a one yet
If Not hasOne Then 'if not:
If dataCell.Value = "1" Then
hasOne = True 'Yay! we found a 1!
End If
Else 'We already have a one, see if the new cell is 0
If dataCell.Value = "0" Then 'if 0:
switchToZero = True 'Now we have a zero
Exit For 'No need to continue looking, we know we already changed
End If
End If
Next dataCell 'move over to the next peice of data
If switchToZero Then 'If we did find a switch to zero:
'Copy and paste whole row down
myCell.EntireRow.Copy
dataSht.Cells(copyRow, 2).EntireRow.PasteSpecial xlPasteAll
Application.CutCopyMode = False
copyRow = copyRow + 1 'increment copy row to not overwrite
End If
Next myCell
'housekeeping
Set dataSht = Nothing
Set myRange = Nothing
Set myCell = Nothing
Set data = Nothing
Set dataCell = Nothing
End Sub
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've got some code working to condense multiple columns in excel, removing any blank cells and shunting the data upwards.
Every cell contains formulae, I did find a code snippet that let me use a specialcells command, but that only removed truly blank cells and not ones that contained a formula, where the outcome would make the cell blank.
This is what I'm currently using, which was an edit of something I found on this site a while ago:
Sub condensey()
Dim c As Range
Dim SrchRng
Set SrchRng = ActiveSheet.Range("B2", ActiveSheet.Range("B208").End(xlUp))
Do
Set c = SrchRng.Find("", LookIn:=xlValues)
If Not c Is Nothing Then c.Delete
Loop While Not c Is Nothing
End Sub
I tried increasing the range on the active sheet to include a second column, but excel just goes nuts, assuming it's trying to do it for every cell in the entire table.
I've then repeated this piece of code for each column that I want to condense.
Now this is great, it does exactly what I want to do, but it is slow as anything, especially when each column can contain up to 200+ rows. Any ideas on how to improve the performance of this, or maybe re-write it using a different method?
This ran in <1sec on 300rows x 3cols
Sub DeleteIfEmpty(rng As Range)
Dim c As Range, del As Range
For Each c In rng.Cells
If Len(c.Value) = 0 Then
If del Is Nothing Then
Set del = c
Else
Set del = Application.Union(del, c)
End If
End If
Next c
If Not del Is Nothing Then del.Delete
End Sub
I found that using AutoFilter on each column was faster than looping through each cell in the range or "Find"ing each blank cell in the range. Using the code below and some sample data (3 columns with approximately 300 rows of blank and non blank cells), on my machine it took 0.00063657 days. Using the loop through each cell method, it took 0.00092593 days. I also ran your code on the sample data, and it took a lot longer (I didn't let it finish). So far, the method below yields the quickest results, though I imagine someone will find a faster method.
It appears that the delete method is the biggest bottleneck. It may be fastest to filter the non-blank cells and paste them into a new range, and then delete the old range once you're finished.
Sub condensey2()
Dim c As Range
Dim tbl As Range, tblWithHeader As Range, tblEnd As Range, delRng As Range
Dim i As Long
Dim maxRows As Long
Dim t As Double
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.Calculate
maxRows = ActiveSheet.Rows.Count
ActiveSheet.AutoFilterMode = False
With ActiveSheet
Set tblEnd = Range(.Cells(maxRows, 1), .Cells(maxRows, 3)).End(xlUp)
Set tbl = Range(.Cells(2, 1), Cells(tblEnd.Row, 3))
End With
t = Now()
Set tblWithHeader = tbl.Offset(-1).Resize(tbl.Rows.Count + 1)
i = 1
For i = 1 To tbl.Columns.Count
With tblWithHeader
.AutoFilter
.AutoFilter field:=i, Criteria1:="="
End With
Set delRng = tbl.Columns(i).Cells.SpecialCells(xlCellTypeVisible)
ActiveSheet.AutoFilterMode = False
delRng.Delete xlShiftUp
'redefine the table to make it smaller to make the filtering efficient
With ActiveSheet
Set tblEnd = Range(.Cells(maxRows, 1), .Cells(maxRows, 3)).End(xlUp)
Set tbl = Range(.Cells(2, 1), Cells(tblEnd.Row, 3))
End With
Set tblWithHeader = tbl.Offset(-1).Resize(tbl.Rows.Count + 1)
Next i
t = Now() - t
Debug.Print Format(t, "0.00000000")
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
So I need to extract information from a sheet with only certain values. From about 550 rows down to 50 which are spread across the entire sheet.
So I used autofilter for that. Now I only see the rows which match to my criteria but how can I get the values of a specific range from?
This far I came:
I know that I have to use
RangeINamed.SpecialCells(xlCellTypeVisible)
to work with only the visible information.
It worked for getting the starting and last row
startRow = bulkbatchRange.SpecialCells(xlCellTypeVisible).row
endRow = startRow + bulkbatchRange.SpecialCells(xlCellTypeVisible).rows.Count
But now I need to get the value of a specific column, I want to use a For loop so I can loop through all visible rows.
So I tried to do
RangeINamed.SpecialCells(xlCellTypeVisible).range("U" & rowNumber).value
That didn't work it gave me nothing. Now I'm rather clueless so does someone maybe know how I get the value of that row in column U in RangeINamed?
Thank you
You can always retrieve the value in a specific cell like U10 with:
Range("U10").Value
whether the row is hidden or not.
EDIT#1:
Here is a little example that loops down thru column A of an AutoFiltered table. It looks for the third visible row (not including the header row):
Sub GoDownFilter()
Dim rLook As Range, r As Range
Set rLook = Intersect(ActiveSheet.UsedRange, Range("A:A").Cells.SpecialCells(xlCellTypeVisible))
rLook.Select
K = 0
For Each r In rLook
If K = 3 Then
r.Select
MsgBox "The third visible row has been selected"
Exit Sub
End If
K = K + 1
Next r
End Sub
I think you need to choose if you want to get a specific cell like:
Range("U10").Value
Or a relative cell using something like
RangeINamed.SpecialCells(xlCellTypeVisible)(2,3).Value
Or
RangeINamed.SpecialCells(xlCellTypeVisible)(2,3).Address 'To see if you are getting it right
EDIT:
A complete code to Filter and Iterate.
Sub Filter()
Dim tableRange As Range, var, actualRow As Integer, lastRow As Integer
Set tableRange = Range("PUT_THE_TABLE_RANGE_HERE")
' Filter
With tableRange
Call .AutoFilter(5, "SPECIFIC_FILTER")
End With
Set f = tableRange.SpecialCells(xlCellTypeVisible)
With tableRange
Call .AutoFilter(5)
End With
For Each var In f.Cells.Rows
actualRow = var.Row
If actualRow <> 1 Then
' Do something
End If
Next
End Sub