I have the code of this macro which removes leading and trailing spaces in cells with text or numbers:
Sub LIMPIAR()
Dim i As Integer
For i = 2 To 20628
Cells(i, 7).Value = Trim(Cells(i, 6).Value)
Next
End Sub
However , there are cells which its content is " ". So I would like to convert that kind of cells to "". How Can I do that?
EDIT: I'm working with scraped data.
Maybe dealing with them like this can help:
If Len(Cells(i,6).Value) <= 2 Then Cells(i, 7).Value = "" End If
OR
If Cells(i,6).Value = " " Then Cells(i, 7).Value = "" End If
Not a very elagent solution, but I would make use of the split function and then reconcatenate the elements of the resulting array. Assuming your string is in cell A1,
mystring = ""
myarray = Split(Cells(1, 1), " ")
For i = LBound(myarray) To UBound(myarray)
If Trim(myarray(i)) <> "" Then
mystring = mystring & Trim(myarray(i)) & " "
End If
Next i
MsgBox Trim(mystring)
mystring should provide a string with just one space between words. You could put this code inside your loop.
Related
I am trying to change a case of particular character in a cell but i think i am missing very small thing in it.
Eg.
The cell has value 'A for Apple and GORILLA wears pajama'
so i am trying to change case of individual 'A' into lower case 'a'.
Now there are 3 scenarios:
A can be in Starting of cell.
A can be in Middle of cell.
A can be in End of cell.
for the middle one I have solution:
Activecell.value = Replace(Activecell.value," A "," a ",vbTextCompare)
but for other 2 when I'm trying to do change other A's also changing, for example:
Activecell.value = Replace(Activecell.value,"A ","a ",vbTextCompare)
this is giving answer 'a for Apple and GORILLa wears pajama'
wherein I'm trying to get 'a for Apple and GORILLA wears pajama'
my code is
Do Until ActiveCell.Offset(0, -cnt).Value = "" And ActiveCell.Offset(0, -cnt1).Value = ""
actc = ActiveCell.Value
If actc = "" Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Value = Replace(ActiveCell.Value, " m ", " m ", , , vbTextCompare)
ActiveCell.Value = Replace(ActiveCell.Value, " cm ", " cm ", , , vbTextCompare)
ActiveCell.Value = Replace(ActiveCell.Value, " dm ", " dm ", , , vbTextCompare)
ActiveCell.Value = Replace(ActiveCell.Value, " mm ", " mm ", , , vbTextCompare)
ActiveCell.Value = Replace(ActiveCell.Value, " mg ", " mg ", , , vbTextCompare)
End If
Loop
To replace only the "A " in the beginning check this in particular.
If Left$(ActiveCell.Value, 2) = "A " Then
ActiveCell.Value = "a" & Right$(ActiveCell.Value, Len(ActiveCell.Value) - 1))
End If
Accordingly for the " A" in the end (Even if I don't know about sentences ending with " A")
If Right$(ActiveCell.Value, 2) = " A" Then
ActiveCell.Value = Left$(ActiveCell.Value, Len(ActiveCell.Value) - 1)) & "a"
End If
The VBA Replace function will replace ALL instances of the substring in the target string.
To specify beginning and/or end of the string, you can test for the presence of the substring and, if it is present, use a different function (I chose to use the Replace Worksheet function) to replace only that character. Examine the following code snippet for an example.
With ActiveCell
If .Value Like "A*" Then .Value = WorksheetFunction.Replace(.Value, 1, 1, "a") 'Beginning only
If .Value Like "*A" Then .Value = WorksheetFunction.Replace(.Value, Len(.Value), 1, "a") 'End only
End With
If, on the other hand, you want the sentence to start (or end) with the word A, implying there is a space after (or before) the A, then change the Like pattern to reflect that "A *" or `* A"
If all of those substrings are, in fact, words, and you want to replace them all in each ActiveCell, you can either construct multiple loops along the format of what you are doing, or you could use Regular Expressions.
For example, the following will replace all instances of the capitals you have indicated with their lower case equivalents, whether they are at the beginning, middle or end.
The macro first matches all of the instances of the different words in sPat, and then cycles through the sentence to replace them. (Note that we must go from last to first in the loop, since the lengths of each word may not be the same).
Option Explicit
Sub doit()
ActiveCell = replaceCaps(ActiveCell)
End Sub
Function replaceCaps(ByRef S As String)
Const sPat As String = "\b(?:A|M|CM|DM|MM|MG)\b"
Dim RE As Object, MC As Object
Dim I As Long
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = True
.ignorecase = False
.Pattern = sPat
If .test(S) = True Then
Set MC = .Execute(S)
For I = MC.Count - 1 To 0 Step -1
S = WorksheetFunction.Replace(S, MC(I).firstindex + 1, Len(MC(I)), LCase(MC(I)))
Next I
replaceCaps = S
Else
replaceCaps = S
End If
End With
End Function
I am trying to do some renaming and I do not want the code to run if the last 3 characters = pdf. Should be simple, but when I run the macro the renaming works fine but it deletes every cell that ends with pdf.
SearchChar = "pdf"
For Each bCell In rng.Cells
Select Case Len(bCell)
Case 2
If Right(bCell, 3) <> SearchChar Then 'This must be wrong
val = SearchSite & Left(bCell, 1) & "00" & Mid(bCell, 2, 1) & "1.pdf"
End If
End Select
bCell.Value = val
Next
Have you tried changing your If statement to check if the right 3 characters are pdf, then "nothing" else your code? Would be similar to:
If Right(bCell,3)=SearchChar Then
'Nothing
Else
val = SearchSite & Left(r, 1) & "00" & Mid(r, 2, 1) & "1.pdf"
bCell.Value=val
End If
My guess is that where the last 3 characters are pdf, val = nothing, so what is printed out is bCell.Value= nothing, so it deletes it. I moved that inside the else section.
You may try like this to rename selection items not ending with "pdf"
Set rng = Selection
SearchChar = "pdf"
Select Case n
Case 2
For Each r In rng
If Right(r, 3) <> SearchChar Then 'This must be wrong
r = SearchSite & Left(r, 1) & "00" & Mid(r, 2, 1) & "1.pdf"
End If
Next
End Select
How can I remove all characters from inputbox, leaving just numbers?
I have a macro that runs down a column removing white space, shortening to 13 digits but I also need it to remove any text characters.
I still think a regexp is the way to go.
Function removeAlpha(strData As String) As String
strData = Replace(strData, " ", "")
With CreateObject("vbscript.regexp")
.Pattern = "[A-Za-z]"
.Global = True
removeAlpha = .Replace(strData, "")
End With
End Function
And to test:
Sub TestClean()
Const strTest As String = "qwerty123 456 uiops"
MsgBox removeAlpha(strTest)
End Sub
An alternate method to using a regular expression is:
Public Sub removeCharacters()
For Each RANGE_UNASSIGNED In Worksheets(1).Range("A1:A" & Worksheets(1).Range("A1").End(xlDown).Row)
STRING_OUTPUT = ""
For INTEGER_STEP = 1 To Len(RANGE_UNASSIGNED.Value)
STRING_TEMPORARY = Mid(RANGE_UNASSIGNED.Value, INTEGER_STEP, 1)
If STRING_TEMPORARY Like "[a-z.]" Or STRING_TEMPORARY Like "[A-Z.]" Then
STRING_xOUTPUT = ""
Else
STRING_xOUTPUT = STRING_TEMPORARY
End If
STRING_OUTPUT = STRING_OUTPUT & STRING_xOUTPUT
Next INTEGER_STEP
RANGE_UNASSIGNED.Value = STRING_OUTPUT
Next RANGE_UNASSIGNED
End Sub
This should remove all alpha characters from your cell(s). You can remove additional characters if required.
An approach based on IsNumeric.
Sub Keep_If_IsNumeric()
For j = 1 To Cells(Rows.Count, "A").End(xlUp).Row
Set c = Cells(j, 1)
strc = ""
For i = 1 To Len(c.Value)
n = Mid(c.Value, i, 1)
If Not IsNumeric(strc & n & "0") Then
Else
strc = strc & n
End If
Next
c.Offset(, 1) = strc
c.Offset(, 2) = Val(Replace(strc, ",", "."))
Next
End Sub
I have a column of something that would be like XXX US, and I want to return XXX for the cell. I want to make a macro that deletes the whole column with one click. For some reason my ticker part of my code throws an error, but when i don't use a loop it works. Is there anything I can do?
Sub DEAS()
Dim cellText As String
Dim ticker As String
Dim i As Integer
i = 5
Do While i < 8000
cellText = Cells(i, 1).Value
ticker = Left(cellText, InStr(cellText, " ") - 1)
Cells(i, 1).Value = ticker
i = i + 1
Loop
End Sub
Give this a try:
Sub DEAS()
Dim cellText As String
Dim ticker As String
Dim i As Integer
i = 5
Do While i < 8000
cellText = Cells(i, 1).Value
If InStr(cellText, " ") > 0 Then
Cells(i, 1).Value = Split(cellText, " ")(0)
End If
i = i + 1
Loop
End Sub
Left(cellText, InStr(cellText, " ") - 1) will throw an error 5 "Invalid procedure call or argument" if the cellText doesn't contain a space. This is most likely due to encountering a value somewhere in A5:A8000 that either isn't in the expected format or is empty. In that case, Instr will return 0, which makes your call evaluate to Left(cellText, -1). You need to check the return value first (note that you can also use a For loop - IMHO more readable when your conditions are fixed):
Sub DEAS()
Dim cellText As String
Dim ticker As String
Dim i As Integer
Dim pos As Integer
For i = 5 To 8000
cellText = Cells(i, 1).Value
pos = InStr(cellText, " ")
If pos > 0 Then
ticker = Left(cellText, pos - 1)
Cells(i, 1).Value = ticker
End If
Next i
End Sub
I am currently using this code(from a fellow user here) to find every cell in column b1 and to find the ones that contain a ";" something like "hello;goodbye". The code will split the cell at the ";" and place "goodbye" directly beneath "hello;" on an entirely new row..
What I need now is this... if a cell contains multiple ";" (ie "hello;goodbye;yo;hi;hey") it will split at EACH ";" not just the first and then move each to a new row directly beneath the other...
What changes do I need to make?
Dim r1 As Range, r2 As Range
Dim saItem() As String
For Each r1 In ActiveSheet.Range("B1", Cells(Application.Rows.Count, 2).End(xlUp))
If InStr(1, r1.Value2, ";") > 0 Then
saItem = Split(r1.Value2, ";")
r1 = Trim$(saItem(0)) & ";"
r1.Offset(1).EntireRow.Insert (xlDown)
r1.Offset(1) = Trim$(saItem(1))
End If
Next r1
I know it's close to what you have, but I wanted to suggest you use Application.ScreenUpdating. This will save considerable time, especially when inserting/deleting rows in Excel. I also wanted to suggest you change the variable names to somehting a little more meaningful.
Sub SplitCells()
Application.ScreenUpdating = False
Dim strings() As String
Dim i As Long
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If InStr(Cells(i, 2).Value, ";") <> 0 Then
strings = Split(Cells(i, 2).Value, ";")
Rows(i + 1 & ":" & i + UBound(strings)).Insert
Cells(i, 2).Resize(UBound(strings) + 1).Value = _
WorksheetFunction.Transpose(strings)
End If
Next
Application.ScreenUpdating = True
End Sub
P.S. Smaller alterations is to use "2" instad of "B". If you are using cells() instead of Range(), may as well go all the way :)
I found an answer over at
http://www.excelforum.com/excel-programming/802602-vba-macro-to-split-cells-at-every.html
This is the solution I was given:
Sub tgr()
Dim rindex As Long
Dim saItem() As String
For rindex = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
If InStr(Cells(rindex, "B").Value, ";") > 0 Then
saItem = Split(Cells(rindex, "B").Value, ";")
Rows(rindex + 1 & ":" & rindex + UBound(saItem)).Insert
Cells(rindex, "B").Resize(UBound(saItem) + 1).Value = WorksheetFunction.Transpose(saItem)
End If
Next rindex
End Sub