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
Related
I am trying to work on a VBA macro that would extract two numbers from a cell and then add them together. The spreadsheet I am working on has a field like this:
Cell D1: .60 #2021-71; 0.90 #2021-71
I need to take the .60 and .90 out, add them together, and place them back in the cell.
For reference, there are other cells in this column that are like this:
Cell D2: .70 #2021-71
I have code that is already looking through the column and removing everything from the # sign on:
Dim tmp As String
For Each cell In Range("D:M")
If InStr(cell.Value, "#") > 0 Then
tmp = cell.Value
cell.Value = Left(tmp, InStr(tmp, "#") - 1)
End If
Is what I am trying to do even possible?
I've taken the approach of providing a custom function which you can then refer to on sheet.
You can call the function whatever you want...!
Public Function SumFirstNumbers(ByVal rngCell As Range) As Variant
Dim arrValues, i As Long, strValue As String, dblValue As String
If InStr(1, rngCell.Text, "#") > 0 Then
arrValues = Split(rngCell.Text, ";")
For i = 0 To UBound(arrValues)
dblValue = 0
strValue = Split(Trim(arrValues(i)), " ")(0)
If IsNumeric(strValue) Then dblValue = CDbl(strValue)
SumFirstNumbers = CDbl(SumFirstNumbers) + dblValue
Next
Else
SumFirstNumbers = rngCell.Value
End If
End Function
Then just use it like any other function in a cell...
This way, you can fill down and across and not have to worry about where the source data actually resides.
To then put it back in the original cells, just Copy → Paste Special → Values.
If it produces an incorrect result (before copying back to the original cells), the function can be changed and the data is still protected.
Naturally, this could still be incorporated into a wider macro if need be. You just need to apply it to your original code.
Dim tmp As String
For Each cell In Range("D:M")
If InStr(cell.Value, "#") > 0 Then
tmp = cell.Value
cell.Value = SumFirstNumbers(cell)
End If
Next
... something like that anyway.
Non VBA Method
Using formulas only. I have indented the formula (you can do that in the formula bar) for a better understanding.
=IFERROR(
IF(
ISNUMBER(SEARCH(";",D1)),
VALUE(MID(D1,SEARCH(";",D1)+1,SEARCH("#",D1,SEARCH(";",D1)+1)-SEARCH(";",D1)-1)) + VALUE(LEFT(D1,SEARCH("#",D1)-1)),
VALUE(LEFT(D1,SEARCH("#",D1)-1))
),0
)
Logic:
Check if there is ; using SEARCH(). Use ISNUMBER() to handle the formula if it doesn't exist.
If there is ; then get the text between ; and # using MID(). Convert them to values using VALUE() and add them up.
If there is no ; then just use LEFT() to get the number before #.
VBA Method
In case you are looking for VBA method to replace the values in the same column then here is a faster method using WildCards. If you have lots of data then in the end where I am using For Each aCell In rng, put the data in an array and loop the array instead.
Logic:
Make Excel do most of the Dirty work!
Replace every thing that is between ";" and "#" with "" using inbuit .Replace with wildcard "#*;"
Replace every thing that is after "#" with "" using wildcard "#*"
Remove all spaces
Use Evaluate.
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range, aCell As Range
Dim lRow As Long
Set ws = Sheet1
With ws
With .Columns(4)
.Replace What:="#*;", Replacement:="+", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
.Replace What:="#*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End With
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
Set rng = .Range("D1:D" & lRow)
For Each aCell In rng
aCell.Value = .Evaluate(aCell.Value)
Next aCell
End With
End Sub
In Action
Replace by Numbers
Option Explicit
Sub ReplaceByNumbers()
Const Cols As String = "D:M"
Const FindDelimiter As String = "#"
Const SplitDelimiter As String = ";"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve
Dim rg As Range: Set rg = Intersect(ws.UsedRange, ws.Columns(Cols))
If rg Is Nothing Then Exit Sub ' no data
Dim rCount As Long: rCount = rg.Rows.Count
Dim cCount As Long: cCount = rg.Columns.Count
Dim Data As Variant
If rCount + cCount = 2 Then ' one cell only
ReDim Data(1 To 1, 1 To 1): Data(1, 1).Value = rg.Value
Else ' multiple cells
Data = rg.Value
End If
Dim SubStrings() As String
Dim r As Long, c As Long, n As Long
Dim iPos As Long
Dim Total As Double
Dim cString As String
Dim NumberFound As Boolean
For r = 1 To rCount
For c = 1 To cCount
cString = CStr(Data(r, c))
iPos = InStr(cString, FindDelimiter)
If iPos > 0 Then
SubStrings = Split(cString, SplitDelimiter)
For n = 0 To UBound(SubStrings)
If n > 0 Then
iPos = InStr(SubStrings(n), FindDelimiter)
End If
cString = Trim(Left(SubStrings(n), iPos - 1))
If Left(cString, 1) = "." Then cString = "0" & cValue
If IsNumeric(cString) Then
If NumberFound Then
Total = Total + CDbl(cString)
Else
Total = CDbl(cString)
NumberFound = True
End If
End If
Next n
If NumberFound Then
Data(r, c) = Total
NumberFound = False
End If
End If
Next c
Next r
rg.Value = Data
MsgBox "Replaced by numbers.", vbInformation, "ReplaceByNumbers"
End Sub
I am trying to develop a Find button, to mark in red "ALL" of the word that are contained in a cell.
For example If I have in my cell this text.
"Pepper had peppermint in his pocket"
it should change to this.
"Pepper had peppermint in his pocket"
This code highlights the first word that it finds.
Dim i As Long
Dim oldrngrow As Long
Dim myValue As String
Dim arr() As Variant
arr = Array(TextBox1.Value)
TextBox2.Text = UBound(arr)
For i = 1 To UBound(arr) + 1
myValue = arr(i - 1)
If myValue = vbNullString Then
MsgBox ("Please Enter a Word in Textbox")
End
End If
Set rng = Cells.Find(What:=myValue, After:=Cells(1, i), LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, MatchByte:=True, SearchFormat:=False)
If rng Is Nothing Then
GoTo skip
End If
oldrngrow = rng.Row
Do While rng.Column = i
If ComboBox1.Text = "Red" Then
rng.Characters(InStr(rng, myValue), Len(myValue)).Font.ColorIndex = 3
Set rng = Cells.FindNext(After:=rng)
If oldrngrow = rng.Row Then
Exit Do
End If
Loop
skip:
Next i
Interesting question. After some research, I’ve put together the following code to demonstrate how to highlight every instance of a word in a string within a cell. For the sake of the demonstration, it uses an Input Box to get the desired string-to-highlight (you can change the method), and assumes the range to search is simply A1 – again you can change this to whatever you want.
Make sure you include Option Compare Text at the top of the Sub – otherwise the search will be case sensitive. Let me know how you go.
Option Compare Text
Sub StringColor()
Dim myRange As Range, myCell As Range, myString As String, myCount As Integer
Set myRange = Range("A1")
myString = InputBox("Type the word you want to color in A1")
For Each myCell In myRange
For myCount = 1 To Len(myCell) - Len(myString) + 1
If Mid(myCell, myCount, Len(myString)) = myString Then
myCell.Characters(myCount, Len(myString)).Font.Color = vbRed
End If
Next myCount
Next myCell
End Sub
I'm trying to substitute '. with =
but this code doens't work!
can any one help?
Cells.Replace What:="'.gcmd", Replacement:="=gcmd", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
If the apostrophe is at the very start of the string, it is a Prefix Character and part of the formatting property of the string, not the value property. It tells excel to treat the value as text.
That being the case, you need to clear the format in addition to replacing the value.
Also note that if you do not have a named formula or range defined on your worksheet, the code will not work returning an application error (unless you define the format as Text).
Code could be something like below:
Option Explicit
Sub due()
Dim R As Range, C As Range
Dim FirstAddress As String
Set R = Range("A1:Z100") 'or whatever
With R
Set C = Cells.Find(What:=".gcmd", Lookat:=xlPart, _
LookIn:=xlFormulas, searchorder:=xlByRows, MatchCase:=False)
If Not C Is Nothing Then
FirstAddress = C.Address
If C.PrefixCharacter = "'" Then
C.ClearFormats
C.NumberFormat = "#" 'omit if `gcmd` is a valid name
End If
C.Value = "=" & Mid(C, 2)
Do
Set C = .FindNext(C)
If C Is Nothing Then Exit Do
If C.Address = FirstAddress Then Exit Do
'Note that you don't really have to test for the apostrophe.
'You could just ClearFormats whether it is present or not.
If C.PrefixCharacter = "'" Then
C.ClearFormats
C.NumberFormat = "#" 'omit if `gcmd` is a valid name
End If
C.Value = "=" & Mid(C, 2)
Loop
End If
End With
End Sub
Or perhaps try this?
(not actually really tested this, just rattled it off as an idea)
Private Sub SOAnswer()
Dim C As Range
Dim Str As String
For Each C In Range("A1: R35") 'Define your range here, or use Sheets(1).UsedRange for all cells on the sheet
If InStr(1, ".gcmd", C.Value) <> 0 Then
Str = C.Value
C.Clear
C.Formula = Replace(Str, ".gcmd", "=gcmd")
End If
Next
End Sub
I'm trying to parse left and right empty spaces, nbsp, \n, \t, etc. from all Excel cells in a certain range.
I'm using the following macro:
Sub TRIM_CELLS()
'Clean all conditional formating
Cells.FormatConditions.Delete
'improve performance
Application.ScreenUpdating = False
Dim all_cells_range As String
all_cells_range = "A1:A10"
'Trim all those cells
Range(all_cells_range).Select
For Each cell In Selection.Cells
cell.Value = Application.Substitute(Application.Substitute(CStr(cell.Value), vbLf, vbCr), vbCr, "")
cell = WorksheetFunction.Trim((Application.Clean(Replace(cell.Value, Chr(160), " "))))
Next cell
End Sub
Something like "Maria Tavares " doesn't get trimmed properly.
#Nick: I tried to use your idea and I think the problem is the char itself... Assuming the following loop works as expected I would get the char that is causing the problem.
Take a look at this image:
But nothing gets printed in that place.
Sub TRIM_CELLS()
'Clean all conditional formating
Cells.FormatConditions.Delete
'improve performance
Application.ScreenUpdating = False
Dim all_cells_range As String
all_cells_range = "A1:A2"
'Trim all those cells
Range(all_cells_range).Select
For Each cell In Selection.Cells
For I = 1 To 255
cell = WorksheetFunction.Substitute(cell, Chr(I), I)
Next I
Next cell
End Sub
I use a function that removes any special characters that you define.
Function RemoveSpecialCharacters(wks As Worksheet, strRange As String, var As Variant)
Dim rngAddress As Range, cell As Range, I&
'e.g strRange - "E2:E"
With wks
Set rngAddress = .Range(strRange & .Cells(Rows.count, "A").End(xlUp).row)
For I = LBound(var) To UBound(var)
For Each cell In rngAddress
cell = WorksheetFunction.Substitute(cell, var(I), " ")
Else
cell = WorksheetFunction.Substitute(cell, var(I), "")
Next cell
Next I
End With
End Function
You could call the function like this:
RemoveSpecialCharacters worksheetname, "A1:A", Array(Chr(9), Chr(10), Chr(13), Chr(39))
Where Chr(10) is linefeed character, chr(9) is the tab character etc.
See this link for what other Chr codes stand for.
UPDATE:
Try this to remove the weird "spy" character from the cell.
RemoveSpecialCharacters worksheetname, "A1:A", Array(Chr(160))
Ended up doing a replacement with that "space"... not a great solution but fixed my problem... Just would like to know what char it was...
Sub TRIM_CELLS()
'Clean all conditional formating
Cells.FormatConditions.Delete
'improve performance
Application.ScreenUpdating = False
Dim all_cells_range As String
all_cells_range = "A1:A2"
Range(all_cells_range).Select
For Each cell In Selection.Cells
cell.Replace What:=" ", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
cell.Value = Application.Substitute(Application.Substitute(CStr(cell.Value), vbLf, vbCr), vbCr, "")
cell.Value = WorksheetFunction.Trim(cell)
Next cell
end sub
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