I have a decent sized worksheet and I want to delete/clear the contents of any empty cells. They don't have a space or any character that I can see (Len() returns a zero) and they're being counted by Counta.
Here's the macro I've developed, it's supposed to clear the contents of each cell in the selection that has a length of zero:
Sub NoNull()
Dim rCell As Range
Dim iLen As Integer
For Each rCell In Selection
iLen = WorksheetFunction.Len(Range(rCell))
If iLen = 0 Then rCell.ClearContents
Next rCell
End Sub
I get an error on this line:
iLen = WorksheetFunction.Len(Range(rCell))
I ASSUME it's related to the way I input the rCell into the Len formula.
You are VERY CLOSE:
Sub NoNull()
Dim rCell As Range
Dim iLen As Integer
For Each rCell In Selection
iLen = Len(rCell)
If iLen = 0 Then rCell.ClearContents
Next rCell
End Sub
If the cells are truly blank then you can do this in a single shot with SpecialCells
If the cells may contain formulae that evaluate to a zero length string then your original loop can be improved by turning off ScreenUpdating and removing the redunandant iLen = Len(rCell))
for tuly empty cells
Sub NoNull()
On Error Resume Next
Selection.SpecialCells(xlBlanks).ClearContents
End Sub
better loop code
Sub NoNull()
Dim rCell As Range
Application.ScreenUpdating = False
For Each rCell In Selection
If Len(rCell.Value) = 0 Then rCell.ClearContents
Next rCell
Application.ScreenUpdating = True
End Sub
Related
In my office we tally bags with a barcode scanner, but some times the user edits the Excel cell, giving the bag number manually, so I want to stop manually writing in excel cell.
That cell must update only by scanner.
I've tried the code below, and it returns the keystroke count but not the time.
Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.Address = Range("A1:A100") Then
'Enter Code or Call any Function if any process has to be performed
'When someone Edits the cell A1
If Range(ActiveCell, ActiveCell.Offset(numRows, numCols)).Offset.Value = "" Then
Call Demo
Else: End If
End Sub
Sub Demo()
'Specify a range (change to suit)
MsgBox CountKeystrokes(Sheets("Sheet1").Range("A:A"))
If Range(ActiveCell, ActiveCell.Offset(numRows, numCols)).Offset.Value <> "" Then
Range(ActiveCell, ActiveCell.Offset(numRows, numCols)).Select
Selection.ClearContents
Else
End If
End Sub
Function CountKeystrokes(rng As Range) As Long
Dim rCell As Range
Dim iCtr As Long
For Each rCell In rng
iCtr = iCtr + Len(rCell.Formula)
Next
CountKeystrokes = iCtr
End Function
As an extension from the last question I asked, I'm trying to run a macro across all worksheets, which you guys successfully helped me to do.
I've been told that the worksheet names can't be hardcoded, so I'm going to have to modify my current solution.
Sub RemoveCarriageReturns()
Dim MyRange As Range
Dim NameList() As Variant
NameList = Array("OTCUEXTR", "OTFBCUDS", "OTFBCUEL")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 0 To 2
With Worksheets(NameList(i))
For Each MyRange In .UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
MyRange = Replace(MyRange, Chr(10), "")
End If
Next MyRange
End With
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I've tried to populate the array with a For loop that gathers names of each worksheet however I feel after 2 days blankly staring at this, my limited VBA knowledge has run out and I'm stuck, I would really appreciate some pointers on how to get this macro to work across an range of sheets that can change in quantity and names.
Happy to provide any more information you need in a comment
You can do it like this (or could use the index along the lines of your original code).
Sub RemoveCarriageReturns()
Dim MyRange As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each ws In Worksheets
With ws
For Each MyRange In .UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
MyRange = Replace(MyRange, Chr(10), "")
End If
Next MyRange
End With
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Public Function GetSheetNames(ByVal wbk As workbook) As String()
Dim names() As String
Dim count As Integer
Dim i As Integer
count = wbk.Worksheets.count
ReDim names(count - 1)
For i = 1 To wbk.Worksheets.count
names(i - 1) = wbk.Worksheets(i).Name
Next
GetSheetNames = names
End Function
Usage: GetSheetNames(Application.ActiveWorkbook)
UPDATE: For selected sheets only:
Public Function GetActiveSheetNames(ByVal wbk As workbook) As String()
Dim names() As String
Dim count As Integer
Dim i As Integer
count = wbk.Windows(1).SelectedSheets.count
ReDim names(count - 1)
For i = 1 To wbk.Windows(1).SelectedSheets.count
names(i - 1) = wbk.Windows(1).SelectedSheets(i).Name
Next
GetActiveSheetNames = names
End Function
So I'm writing some VBA code that goes through my document and looks for where a formula returns an error and it merges and centers it with the cell that's underneath it.
Private Sub CommandButton22_Click()
Dim strTemp As String
Dim ev As Variant
Dim rng As Range, cell As Range
Set rng = Range("H87:H89")
For Each cell In rng
If (cell.HasFormula) Then
cell.Select
strTemp = ActiveCell.Formula
ev = Evaluate(strTemp)
If (IsError(ev)) Then
ActiveCell.Clear
ActiveCell.Merge ([0,1])
End If
End If
Next cell
End Sub
This is what I have so far, it clears the cell properly but won't merge.
Try using:
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row + 1, ActiveCell.Column)).Merge
Hope it helps.
Something like this. Note you rarely need select/activate and should try to avoid it as much as possible.
Private Sub CommandButton22_Click()
Dim cell As Range
For Each cell In Range("H87:H89").Cells
If cell.HasFormula Then
If IsError(cell.Value) Then
cell.Clear
cell.Resize(2, 1).Merge
End If
End If
Next cell
End Sub
I am programming to review a range, remove content from the range of cells, then delete the entire row of cells that have been cleared of content. Currently, I run the code and all the rows are getting deleted. Also, I appreciate suggestions to make the code DRY.
Option Explicit
Sub Alfredo()
Dim msg As String
Dim VarCase As Range
Dim ws As Worksheets
Set ws = Sheets("Data")
For Each VarCase In ws.Range("D1:D11000")
If VarCase.Value2 = "John" Or VarCase.Value2 = "Thompson" Or VarCase.Value2 =
"Mattson" Then
VarCase.ClearContents
End If
Next VarCase
For Each VarCase In ws.Range("D1:D11000")
If VarCase.Value = "" Then
Rows.EntireRow.Delete
End If
Next VarCase
End Sub
In your final For loop, you have
Rows.EntireRow.Delete
where you should have
VarCase.EntireRow.Delete
which probably accounts for the general deletion.
The For Each construct doesn't always work happily with a range that is being changed (here by row deletion), so beware that. You could potentially accumulate a Range of deletion targets via Union and delete in one statement at the end for DRYness, without any clearing of contents.
Also, indentation is your friend.
Edit to add illustration of Union approach:
Sub TestRowDelete()
Dim ARange As Range
Dim DRange As Range
Set DRange = Nothing
For Each ARange In ActiveSheet.UsedRange.Rows
If ARange(1).Value = "d" Then ' testing first cell on each row
If DRange Is Nothing Then
Set DRange = ARange
Else
Set DRange = Union(DRange, ARange)
End If
End If
Next ARange
If Not DRange Is Nothing Then DRange.EntireRow.Delete
End Sub
Just put this code under this code under the data worksheet in VBA
Sub Alfredo()
Dim msg As String
Dim VarCase As Range
For Each VarCase In ActiveSheet.Range("D:D")
If VarCase.Value2 = "John" Or VarCase.Value2 = "Thompson" Or VarCase.Value2 = "Mattson" Then
VarCase.ClearContents
End If
Next VarCase
For Each VarCase In ActiveSheet.Range("D:D")
If VarCase.Value = "" Then
VarCase.EntireRow.Delete
End If
Next VarCase
End Sub
Why loop twice?
Application.ScreenUpdating = False
Dim VarCase As Range
Dim ws As Worksheet
Set ws = Sheets("Data")
For Each VarCase In ws.Range("D1:D11000")
If VarCase.Value2 = "John" Or VarCase.Value2 = "Thompson" Or VarCase.Value2 = "Mattson" Then
VarCase.ClearContents
VarCase.EntireRow.Delete
End If
Next VarCase
I am using the SHEETOFFSET VBA code
Function SHEETOFFSET(offset, Ref)
' Returns cell contents at Ref, in sheet offset
Application.Volatile
With Application.Caller.Parent
SHEETOFFSET = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Value
End With
End Function
And then the following code within within my new sheet
=sheetoffset(-1, B2)
to copy the value of cell B2 in the previous sheet to my new sheet.
However, I also need to copy the color of that particular cell. Is there any code that I can enter in the original VBA code above to do this? Or is there another way of achieving this?
Many thanks for your help
Tim
Logic:
Define a Public variable to hold the color of the cell
In Worksheet_Change check if the above variable has any value. If yes then change the color of the target cell.
Once the above is done, reset the variable to 0
Code in Module:
Public cellColor As Double
Function SHEETOFFSET(offset, Ref)
With Application.Caller.Parent
SHEETOFFSET = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Value
'~~> Store the color in a variable
cellColor = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Interior.ColorIndex
End With
End Function
Code in Sheet Code Area:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
On Error GoTo Whoa
Application.EnableEvents = False
For Each aCell In Target.Cells
If cellColor <> 0 Then aCell.Interior.ColorIndex = cellColor
Next
Letscontinue:
cellColor = 0
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
ScreenShot:
My Personal Thoughts:
I am not in favor of the SHEETOFFSET function in the first place because the formula is actually referring a cell in the current sheet. Any changes, for example, deletion of that cell will error out your formula
It is better to link the cells directly
FOLLOWUP (From Comments)
You can run this code in the end to refresh all formulas.
Sub Sample()
Dim ws As Worksheet
Dim rng As Range, aCell As Range
For Each ws In ThisWorkbook.Sheets
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng Is Nothing Then
For Each aCell In rng
aCell.Formula = aCell.Formula
Next
End If
Next
End Sub