Clearing Cell Values of a table if matching criteria - excel

I am looking to sort through a specific range of cells and look to see if the LEN(gth) of that cell is equal to 20. If it is, I would like to clear the contents of said cell and move to the next until they are all evaluated.
I have this report that is pulled from a website and exported to excel and the annoyance is a 0.0% that shows up as pound signs (# x's 20). I've tried other macros that search for strings, it completely ignores 0%, the one constant is that each cell that this appears in is exactly 20 characters in length.
What should happen is that I am:
1 Searching C3:U20
2 for cell.len = 20
3 if activecell = matches criteria
4 then clear.contents
5 Goto 1 until all activecells with a len of 20 are cleared
Thank you for any assistance you can provide.
G
*EDIT*
Since I couldn't make that work, I used a "work around". It's inefficient as all blarp but since it's only used on a small table it doesn't really matter. I just have to do this in "three" seperate scripts. I found that if I converted the ranges from Percentage formatting to General, I could just look for the overflow number as a string. Then once they are "cleared" I just reconvert those columns to a percentage formatting:
Sub sub_ConvertToGeneral()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''' Convert the Percentage Columns to General Format
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Columns("F:F").Select
'Application.FormulaBarHeight = 2
Range("F:F,H:H,L:M,O:O,S:S,U:U").Select
Range("U1").Activate
Selection.NumberFormat = "General"
'Selection.NumberFormat = "0.00%"
Range("A1:B1").Select
End Sub
Sub sub_Overflow()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''' Find Overflow and delete every instance of it
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FindString As String
Dim rng As Range
FindString = "2.6965E+308"
50
If Trim(FindString) <> "" Then
With Sheets("Main Import").Range("C1:U20")
Set rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
Application.Goto rng, True
ActiveCell.ClearContents
Do
Set rng = .FindNext(rng)
GoTo 50
Loop While Not rng Is Nothing
Else
End If
End With
End If
Range("A1").Select
End Sub
Sub sub_ConvertToPercentage()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''' Convert the General Columns to Percentage
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Columns("F:F").Select
'Application.FormulaBarHeight = 2
Range("F:F,H:H,L:L,O:O,S:S,U:U").Select
Range("U1").Activate
'Selection.NumberFormat = "General"
Selection.NumberFormat = "0.00%"
Range("A1:B1").Select
End Sub

If the cells to be cleared actually contain exactly 20 characters (So LEN(A1) would display 20), then Select the cells you want to examine and try:
Sub dural()
For Each r In Intersect(Selection, ActiveSheet.UsedRange)
If Len(r.Text) = 20 Then
r.Clear
End If
Next r
End Sub
EDIT#1:
This version will clear cells with a value greater than 1.0E+307:
Sub dural()
For Each r In Intersect(Selection, ActiveSheet.UsedRange)
If IsNumeric(r.Value) Then
If r.Value > 1E+307 Then
r.Clear
End If
End If
Next r
End Sub

Related

Find and replace using VBA

I have a chart where I need to remove certain keywords from column C- Range C3:C5000(some cells are blank). The words that needs to be removed are placed in column A- Range A3:A100(some cells are blank). Both ranges gets changed for different files. I have written a code but its not working for dynamic range. Also I want to sort column c according to no. of characters in cell in Ascending order. please help
Sub Replace_Char()
Dim i As Integer
Dim Mpp As String
For i = 3 To 50
Mpp = Cells(i, 1).Value
If Cells(i, 1).Value <> 0 Then
Worksheets("Sheet1").Columns("C").Replace _
What:=Mpp, Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
End If
Next i
End Sub
For dynamic ranges, you can try using the .UsedRange property.
As for sorting by number of characters, create a column that has the formula like "=LEN(D1)" and then sort the sheet on that column.
Sub Replace_Char()
Dim i As Integer
Dim Mpp As String
'For i = 3 To 50
Dim Thing As Range
For Each Thing In ActiveSheet.UsedRange.Columns(1).Cells
Mpp = Cells(i, 1).Value
If Cells(i, 1).Value <> 0 Then
Worksheets("Sheet1").Columns("C").Replace _
What:=Mpp, Replacement:="", _
SearchOrder:=xlByColumns, MatchCase:=True
End If
'Next i
Next
End Sub

How do you get Excel VBA to recognize numeric cells?

I have a table of numbers that are all left aligned (i.e. Excel recognizes them as text)
I run a VBA script on all cells:
cell.value = cell.Value * 1
This right aligns all of them and Excel recognized them as numbers except for decimals (e.g. 3.14 does not work while 314 works). I also run a find and replace script, where the search is for space (" ") and replace it with a blank(""), so this should get rid of atleast the common space.
Further clues: If i perform the =Value(A1) formula in Excel, Excel will recognize even the decimals as a number. If I run Workbookfunction.value(A1) Excel will not recognize as a number.
So the problem seems ro be related to VBA (?) and decimals. Any solutions?
I now ran the following after comments here:
For Each cell In rng
Dim vNumber As Double
On Error Resume Next
'Remove space
cell.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Remove comma
cell.Replace What:=",", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Check if empty, if it is: Do nothing
If IsEmpty(cell) = True Then
Else
vNumber = CDbl(cell.Value)
cell.Value = vNumber
End If
'Check if numeric
If IsNumeric(cell) = True Then
cell.Interior.Color = RGB(0, 254, 0)
cell.Interior.TintAndShade = 0.8
Else
cell.Interior.Color = RGB(100, 0, 0)
cell.Interior.TintAndShade = 0.8
End If
Next cell
The result is the following Before and After (where one is with Double and other with Variant. Somehow its writing over cells that are not decimals...
You need to convert the value of the cell to a double. For example:
Dim myDouble As Double
myDouble = CDbl(Range("A1").Value)
Debug.Print myDouble
myDouble = myDouble + 1
Debug.Print myDouble
Lines 3 to 5 are just to demonstrate that it gets recognised as a decimal.
Did you try conversion?
Sub test()
Dim rng As Range, cell As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A1:A5")
For Each cell In rng
.Range("B" & cell.Row).Value = CDbl(cell)
Next cell
End With
End Sub
Results:
Val(Cells(1,1).Value will convert a string to a number if it's numeric, to zero if it's not. "123abc" will be converted to the number 123. IsNumeric(Cells(1,1).Value) will return True if there are no non-numeric characters in the cell's string.
Incidentally, VBA's Val() function will ignore blanks. Val(123 456") will return the number 123456.
The code below will meet your updated requirements. Please try it.
Sub ConvertTextToNumbers()
Dim Rng As Range
Dim Cell As Range
Dim Arr As Variant
Dim R As Long
With Worksheets("Sheet1") ' modify to suit
Set Rng = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp))
Arr = Rng.Value
For R = 1 To UBound(Arr)
' remove commas and spaces
Arr(R, 1) = Val(Replace(Replace(Arr(R, 1), " ", ""), ",", ""))
Next R
Rng.Offset(0, 1).Value = Arr
For Each Cell In Rng.Offset(0, 1)
Cell.Interior.Color = IIf(Cell.Value, vbGreen, vbRed)
Next Cell
End With
End Sub

Excel / VBA - How to select the top row (absolute) of whichever column (relative) the currently selected cell is in?

I spent 11 hours a few days ago ripping my brain apart to do this. Everyone either answers using sample ranges with absolute values, or with the entirely relative .offset function. Or they mention it's not good to select in vba, or they provide a workaround of some sort that I can't adapt, or .select doesn't work with R1C1...etc, etc. My script is done now, and fully functioning with the following loop code, but it's SLOW because it uses this loop about 2000-3000 times each time the macro runs:
Do Until Selection.Row = 1
If Selection.Row <> 1 Then
Selection.Offset(-1, 0).Select
End If
Loop
I just want to know, for whichever cell is currently selected, wherever it is, is there a faster way in vba to .Select the top row (row #1, absolute reference) of that (any) column (relative reference)?
For do it faster you can optimize like this:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do Until Selection.Row = 1
If Selection.Row <> 1 Then
Selection.Offset(-1, 0).Select
End If
Loop
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
One question, you can not use Cells(x,y).row instead of Selection metod ? This is a faster way.
In other way, the column normaly have a name in top, you can search this name and get this position an select the row below.
Something like this:
Private Sub CommandButton1_Click()
Dim intColumn As Integer
intColumn = ObtainColumn(Range("A1:F1"), "NameColum")
intRow = ObtainRow(Range("A1:A10"), "NameColum")
Cells(intRow, intColumn).Select
End Sub
Function ObtainColumn(rng As Range, strValue As String) As Long
Dim lCol As Long
'Set rng = ActiveSheet.Cells
On Error Resume Next
lCol = 0
lCol = rng.Find(What:=strValue, _
After:=rng.Cells(1), _
LookAt:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
ObtainColumn = lCol
On Error GoTo 0
End Function
Function ObtainRow(rng As Range, strValue As String) As Long
Dim lRow As Long
'Set rng = ActiveSheet.Cells
lRow = 0
On Error Resume Next
lRow = rng.Find(What:=strValue, _
After:=rng.Cells(1), _
LookAt:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
ObtainRow = lRow
On Error GoTo 0
On Error GoTo 0
End Function
There is no need to iterate to find the top of the current column:
Selection.End(xlUp).Activate
The .End(xlUp) member of a Range finds the end of the contiguous data set. More info here.
or
Cells(1, Selection.Column).Activate
This method uses the Column member of a Range to return the number of that column, then uses the Cells function to call the first row of that column. More info here.
or (as mentioned)
Selection.Offset(1 - Selection.Row).Select
This method uses the Offset member of a Range. This function (more info here) has two optional parameters. The first is RowOffset, so this formula will offset a cell in A21 by -20 rows, thus giving A1.
Edited for more information and references

Check colour of entire column

I'm trying to create an if statement that checks the colour of column B.
It works if I target a single cell in column B not when I try ("B:B").
This is what I have.
Sub FOO()
Dim answer As Range
Set answer = Range("b:b")
If answer.Interior.Color = vbRed Then
MsgBox ("There is an issue with column B, please review.")
End If
End Sub
As we are getting many quality answers, here is the most optimized code. Fastest, I bet :)
It wont work if you are using one of the ancient versions of excel. anything 2007+ is fine.
Sub OptimizedFOO()
Dim rngTemp
With Application.FindFormat.Interior
.Color = vbRed
End With
'/ Sheet1 is example sheet name
Set rngTemp = Sheet1.Columns(2).Find(What:="", SearchFormat:=True)
If Not rngTemp Is Nothing Then
MsgBox ("There is an issue with column B, please review.")
End If
End Sub
Old answer
Sub FOO()
Dim answer As Range
Dim cell As Range
'/ This will show message if at least one cell is found with red color
Set answer = Range("b:b")
For Each cell In answer.Cells
If answer.Interior.Color = vbRed Then
MsgBox ("There is an issue with column B, please review.")
Exit For
End If
Next
End Sub
I am not sure, but give you my best guess.
If VB unifies the properties, then it unifies the properties of all the cells of the column. You can then compare the property to a value and this will be True if all rhe proeprties have that (same) value. Otherwise the comparison will be False.
So If answer.Interior.Color = vbRed will be True if all cells have this propety value vbRed. If you want to check if any of the cells have that color, you may need to iterate over all the cells.
I believe VB and the VB object model work like this, but again, I am not sure.
I would find last used row on column B and than loop through them.
Sub FOO()
Dim LR As Long, I As Long
LR = findLastRow("Sheet1", "B")
For I = 1 To LR
If Range("B" & I).Interior.Color = vbRed Then
MsgBox ("There is an issue with column B, please review.")
Exit For
End If
Next I
End Sub
Function findLastRow(shtName As String, colLetter As String) As Long
With Sheets(shtName)
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
findLastRow = .Cells.Find(What:="*", _
After:=.Range(colLetter & "1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
findLastRow = 1
End If
End With
End Function
You could do something using the autofilter, something like this
Function AnyRedCells(rngRangeToInspect As Excel.Range) As Boolean
Application.ScreenUpdating = False
rngRangeToInspect.AutoFilter
rngRangeToInspect.AutoFilter field:=1, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
' Using >1 as assuming header on column
AnyRedCells = (ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Cells.Count > 1)
rngRangeToInspect.AutoFilter
Application.ScreenUpdating = True
End Function
Used like so
Sub OptimizedFOO2()
If AnyRedCells(Range("b23:b26")) Then
MsgBox ("There is an issue with column B, please review.")
End If
End Sub

Use Find/Replace to clear vbNullString

I have a spreadsheet that is generated as a report in our Enterprise system and downloaded into an Excel spreadsheet. Blank cells in the resulting spreadsheet are not really blank, even though no data is present - and the blank cells do Not contain a 'space' character.
For example, the following cell formula in A2 returns TRUE (if A1 is a blank cell):
=IF(A1="","TRUE","FALSE")
However,
=ISBLANK(A1)
returns FALSE.
You can replicate this problem by typing an apostrophe (') in a cell and copying the cell. Then, use Paste Special...Values to paste to another cell and the apostrophe is not visible in the pasted cell, nor in the Formula Bar. There appears to be a clear cell, but it will evaluate to FALSE using ISBLANK.
This causes sorting to result in the fake blank cells at the top of an ascending sort, when they need to be at the bottom of the sort.
I can use a vba loop to fix the fake blanks, to loop through every column and evaluate
IF Cell.VALUE = "" Then
Cell.Clear
but because the spreadsheet has tens of thousands of rows of data and as many as 50 columns, this adds substantial overhead to the program and I would prefer to use FIND and Replace.
Here is the code that does not currently work:
Range("ZZ1").Copy
Range("Table1[#All]").Select
With Selection
.Replace What:="", Replacement:=.PasteSpecial(xlPasteValues, xlNone, False, False), _
LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
The following things do not work to clear the fake blank cells either:
Replacement:= vbnullstring
Replacement:= ""
Replacement:= Cells.Clear
Replacement:= Cells.ClearContents
Replacement:= Cells.Value = ""
I have tried 20 other things that do not work either.
Try this
With ActiveSheet.UsedRange
.NumberFormat = "General"
.Value = .Value
End With
A variant array provides an efficient way of handling the false empties:
Sub CullEm()
Dim lngRow As Long
Dim lngCol As Long
Dim X
X = ActiveSheet.UsedRange.Value2
For lngRow = 1 To UBound(X, 1)
For lngCol = 1 To UBound(X, 2)
If Len(X(lngRow, lngCol)) = 0 Then X(lngRow, lngCol) = vbNullString
Next
Next
ActiveSheet.UsedRange.Value2 = X
End Sub
The problem is that you are searching for a hidden .PrefixCharacter which are not covered by the standard replacement function. For more information on this you might want to visit MSDN: https://msdn.microsoft.com/en-us/library/office/ff194949.aspx
In order to find and replace these you'll have to use the .Find function because it can look at the formulas (rather than only at a cell's value). Here is a short sample code to illustrate that:
Option Explicit
Public Sub tmpTest()
Dim cell As Range
Dim rngTest As Range
Dim strFirstAddress As String
Set rngTest = ThisWorkbook.Worksheets(1).Range("A1:G7")
Set cell = rngTest.Find("", LookIn:=xlFormulas, lookat:=xlPart)
If Not cell Is Nothing Then
strFirstAddress = cell.Address
Do
cell.Value = vbNullString
Set cell = rngTest.FindNext(cell)
Loop While strFirstAddress <> cell.Address And Not cell Is Nothing
End If
End Sub
I can't figure out anything that you could put in Replacement to get that to work. I'm afraid you're stuck looping. You can reduce the overhead by using .Find instead of looping through every cell.
Sub ClearBlanks()
Dim rng As Range
Dim rFound As Range
Dim sFirstAdd As String
Dim rFoundAll As Range
Set rng = Sheet1.UsedRange
Set rFound = rng.Find(vbNullString, , xlValues, xlWhole)
If Not rFound Is Nothing Then
sFirstAdd = rFound.Address
Do
If rFoundAll Is Nothing Then
Set rFoundAll = rFound
Else
Set rFoundAll = Application.Union(rFound, rFoundAll)
End If
Set rFound = rng.FindNext(rFound)
Loop Until rFound.Address = sFirstAdd
End If
If Not rFoundAll Is Nothing Then
rFoundAll.ClearContents
End If
End Sub
You can use the table filter to select the (seemingly) blank cells in each column and clear the contents. This should be quicker than finding each blank cell.
Sub clearBlankTableEntries()
Dim tbl As ListObject, c As Byte
Set tbl = ActiveSheet.ListObjects("testTable")
For c = 1 To tbl.Range.Columns.Count
tbl.Range.AutoFilter Field:=c, Criteria1:="="
Range(tbl.Name & "[Column" & c & "]").ClearContents
tbl.Range.AutoFilter Field:=c
Next c
End Sub

Resources