I am trying to implement a SPLIT() function to parse a string in EXCEL and distribute the result to adjacent cells on the same form. The following is working as expected, except when a parsed term is a Number.
"0.25" parses to "1/0/1900 6:00:00 AM"
I tried cstr() on the resulting strAttr value, but seems to have no effect. Any ideas?
Sub splitText()
Dim i As Integer
Dim x As Integer
Dim strText As String
Dim strAttr As Variant
Dim strFirst As String
Dim NumRows As Integer
strFirst = "A4"
Sheets("Data").Activate
Range(strFirst).Select
NumRows = Range(strFirst, Range(strFirst).End(xlDown)).Rows.Count
For x = 1 To NumRows
ActiveCell.Offset(1, 0).Select
strText = ActiveCell.Value
strAttr = Split(strText, " ")
For i = 0 To UBound(strAttr)
Cells(x + 4, i + 2).Value = strAttr(i)
Next i
Next
End Sub
Note:
I forced a (') to the front of the string, which seems to provide the desired result, except everything will be = TEXT:
For i = 0 To UBound(strAttr)
Cells(x + 4, i + 2).Value = "'" & strAttr(i)
Next i
Is there a better way to accomplish this and retain "0.25" as a Number value?
Thanks,
mark
This may help. Replace:
strText = ActiveCell.Value
with:
strText = ActiveCell.Text
Related
I have searched many posts, forums, tutorials, I tried combine some of them, but nothing really worked for me. Now I write some code, that by logic I learn from other programming languages it should work, but I'm missing few steps.
Let's assume I have string like this
Test User <TUser#my-domain.pl>; Test User2 <TUser2#my-domain.pl>; Test User3 <TUser3#my-domain.pl>; Test User4 <TUser4#my-domain.pl>;
I paste that into cell, let's say A1. My goal is to be left with Test User or TUser for each smaller string.
I can achive my goal by doing so:
Click Text as columns -> Delimited -> Other ;, now each string is in separate column
Copy whole A row and paste it with transpose(rotate), so each string is in separate row
Now easiest way is to use Text as columns, by < delimiter. So all I'm left with is Name Surname in one cell and rest in other
I want to achive that, by clicking on the button of course.
My code so far:
Sub GetName()
Dim WordList As String
Dim ArrayOfWords
Dim i, i2 As Integer
'Define my word list, based on cell
WordList = Cells(1, 1)
'Use SPLIT function to convert the string to an array
ArrayOfWords = Split(WordList, "<")
'Iterate through array, and put each string into new row cell
i = 2
i2 = 1
Do While (ThereIsNoMoreText)'That I cannot figure out
Cells(2, i).Value = ArrayOfWords(i2)
i = i + 1
i2 = i2 + 1
Loop
End Sub
Thanks for you help in advance and I hope I make it clear :)
Fun little alternative:
Sub Test()
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "(?:<.*?>)"
arr = Split(.Replace([A1], ""), ";")
End With
With Cells(1, 2).Resize(UBound(arr))
.Value = Application.Transpose(arr)
.Value = Application.Trim(.Value)
End With
End Sub
Obviously, be sure to create an explicit sheet reference for Cells.
You need to split by semicolon first.
Break the following apart to get the strings you need:
userlist = Split(Cells(1, 1).Value, ";")
i = 1
For Each user In userlist
i = i + 1
splituser = Split(user, "<")
Cells(i, 1) = splituser(0)
Cells(i, 2) = Mid(splituser(1), 1, Len(splituser(1)) - 1)
Next
In addition to the methods shown in others answers (in particular the very impressive one by #JvdV) you could also try this.
This method does not use For…Next
Sub Users_Email_Split()
Dim aData As Variant
With ThisWorkbook.Worksheets("TEST")
aData = .Cells(1).Value
aData = Left(aData, -2 + Len(aData))
aData = Replace(aData, " <", """,""")
aData = Replace(aData, ">; ", """;""")
aData = "{""" & aData & """}"
aData = Application.Evaluate(aData)
.Cells(2, 2).Resize(UBound(aData), UBound(aData, 2)).Value = aData
End With
End Sub
EDIT
If the string is expected to exceed the 255 characters limit for the Evaluate Function then you could use this method (up to a max of 2086 characters).
This method a creates an User Defined Name with the array string as a formula, then applies the Name as a FormulaArray, and finally sets the value of the range.
Sub Users_Email_Split_Plus255()
Dim aData As Variant
Dim lR As Long, lC As Long
With ThisWorkbook.Worksheets("TEST")
aData = .Cells(11, 1).Value
aData = Left(aData, -2 + Len(aData))
aData = Replace(aData, " <", """,""")
aData = Replace(aData, ">; ", """;""")
aData = "={""" & aData & """}"
lR = 1 + UBound(Split(aData, ";"))
lC = 1 + UBound(Split(Split(aData, ";")(0), ","))
With .Cells(12, 2).Resize(lR, lC)
.Worksheet.Names.Add Name:="_FmlX", RefersTo:=aData
.FormulaArray = "=_FmlX"
.Value = .Value
End With: End With
End Sub
You have to modify the construct a bit
Dim i As Long
Dim FirstPart As String, SecondPart As String
Dim ArrayOfWords
ArrayOfWords = Split(Cells(1, 1).Value, ";")
For i = LBound(ArrayOfWords) To UBound(ArrayOfWords)
If InStr(1, ArrayOfWords(i), "<") > 0 Then
FirstPart = Left(ArrayOfWords(i), InStr(1, ArrayOfWords(i), "<") - 1)
SecondPart = Mid(ArrayOfWords(i), Len(FirstPart) + 1, Len(ArrayOfWords(i)))
Debug.Print FirstPart & "--" & SecondPart
End If
Next i
How do I convert the alpha part of an excel address "$C$2" to 3 and 2 so that I could re-use it in a cell object.
If it is "$E$4", then I need two separate values like 5 (for the letter E) and 4, so that I could reference that using the object - Cells(4,5)
Basically, I am trying to un-merge cells using this code below and that is where the need to get the numeral of the excel cell came about.
Sub UnMerge()
Dim i As Integer
Dim fromRange() As String
Dim toRange() As String
Dim temp() As String
ActiveSheet.UsedRange.MergeCells = False
fromRange() = Split(ActiveCell.Address, "$")
temp() = Split(Selection.Address, ":")
toRange() = Split(temp(1), "$")
For i = fromRange(2) To toRange(2)
If Cells(i, Range(temp(0)).Column) = "" Then
Cells(i, Range(temp(0)).Column) = Cells(i - 1, Range(temp(0)).Column).Value
End If
Next i
End Sub
Debug.Print Range("$E$4").Row & ", " & Range("A1").Column
changing and spliting strings to get to numbers is slow. Just use the selection.rows and selection.column:
Sub UnMerge()
Selection.MergeCells = False
With ActiveSheet
Dim i As Long
For i = Selection.Row To Selection.Rows.Count + Selection.Row - 1
If .Cells(i, Selection.Column) = "" Then
.Cells(i, Selection.Column) = .Cells(i - 1, Selection.Column).Value
End If
Next i
End With
End Sub
I hope you can help.
I have a piece of code that is currently removing all the text from the cells in Column G. What I need is for this code to instead of removing the text I would like it to remove the numbers, and I only want it to remove the numbers at the beginning of the string/cell the rest of the data I would like to remain the same.
I have attached a picture PIC.1 for betting understanding.
PIC1
The code I currently have and I hope can be amended is below and as always any and all help is greatly appreciated.
CODE
Sub RemoveNonDigits()
Dim X As Long, Z As Long, LastRow As Long, CellVal As String
Const StartRow As Long = 1
Const DataColumn As String = "G"
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, DataColumn).End(xlUp).Row
For X = StartRow To LastRow
CellVal = Cells(X, DataColumn)
For Z = 1 To Len(CellVal)
If Mid(CellVal, Z, 1) Like "[!0-9]" Then Mid(CellVal, Z, 1) = " "
Next
With Cells(X, DataColumn)
.NumberFormat = "#"
.Value = Replace(CellVal, " ", "")
End With
Next
Application.ScreenUpdating = True
End Sub
CellVal = LTrimDigits(Cells(X, DataColumn))
With this fairly efficient:
Public Function LTrimDigits(value As String) As String
Dim i As Long
For i = 1 To Len(value) '//loop each char
Select Case Mid$(value, i, 1) '//examine current char
Case "0" To "9" '//permitted chars
Case Else: Exit For '// i is the cut off point
End Select
Next
LTrimDigits = Mid$(value, i) '//strip lead
End Function
See the modified code below:
Sub RemoveNonDigits()
Dim X As Long, Z As Long, LastRow As Long, CellVal As String
Const StartRow As Long = 1
Const DataColumn As String = "G"
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, DataColumn).End(xlUp).Row
For X = StartRow To LastRow
CellVal = Cells(X, DataColumn)
While IsNumeric(Left(CellVal, 1)) ' Here
CellVal = Mid(CellVal, 2) ' all digits at the start
Wend ' are removed
Cells(X, DataColumn) = Trim(CellVal)
Next
Application.ScreenUpdating = True
End Sub
That is, while the starting char in CellVal is a digit, get the substring starting with the second char, and go on until no match.
This function will strip leading digits and spaces from a string
Function RemoveLeadingDigits(str As String) As String
Dim i As Long
Dim chr As String
' Loop through string
For i = 1 To Len(str)
' Get character i
chr = Mid(str, i, 1)
' Keep looping until character is not a number or space
If Not IsNumeric(chr) And Not chr = " " Then
' If it is a number or space, strip checked characters
' from str (because they'll be numeric or space)
str = Right(str, Len(str) - i + 1)
' Stop looping as non-numeric characters encountered
Exit For
End If
Next i
' Return the value of str
RemoveLeadingDigits = str
End Function
You can call it from your code by
Sub RemoveNonDigits()
Dim X As Long, LastRow As Long, CellVal As String
Const StartRow As Long = 1
Const DataColumn As String = "G"
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, DataColumn).End(xlUp).Row
For X = StartRow To LastRow
CellVal = Cells(X, DataColumn).Value
' ----------------------------------------
CellVal = RemoveLeadingDigits(CellVal)
' ----------------------------------------
Next
Application.ScreenUpdating = True
End Sub
A note on your code though:
You should really fully qualify your cells. For instance, wrap the whole looping section in With ThisWorkbook.Sheets("YourSheet") and then accessing cells using .Cells(row, col) rather than just Cells(row, col).
A bit hacky shorter alternative (assuming all values start with integer)
For Each cell in Range([G7], [G7].End(xlDown))
cell.Value2 = Trim(Mid(cell, Len(Str(Val(cell)))))
Next
I think a simple change like this:
For X = StartRow To LastRow
Cells(X, DataColumn).Formular1c1 = Application.Trim(Replace(Cells(X, DataColumn).Text, Val(Cells(X, DataColumn).Text), ""))
Next X
will solve your problem...
So I have a string that looks like this:
99999999999999999999999999999FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF99999^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^C
I am trying to count the length of the first instance of a series of a given consecutive character.
Examples:
"9" as the given char, it should count that first set of 9's and return 30.
"F" as the given char, it should return 11, for the first set of consecutive "F"s that begins after the 30 "9"s.
I"m doing this in Excel, so a formula/VBA solution is ideal. I can translate any code into VBA if necessary though. I feel like this has a Reg-Ex solution but I'm the Jon Snow of Reg-Ex, I know nothing.
Thanks in advance for any insights/advice.
I will just put this here for posterity:
=IF(SUBSTITUTE(MID($A$1,FIND(A2,$A$1),LEN($A$1)),A2,"")="",LEN($A$1)+1,FIND(MID(SUBSTITUTE(MID($A$1,FIND(A2,$A$1),LEN($A$1)),A2,""),1,1),$A$1,FIND(A2,$A$1)))-FIND(A2,$A$1)
This will count the first grouping of the desired input:
And here is a REGEX solution. Note that we have to escape the metacharacters.
Option Explicit
Function LenFirstInstance(findCHAR As String, searchSTRING As String)
Dim RE As Object, MC As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.ignorecase = False
.Pattern = Left(findCHAR, 1) & "+"
If .Pattern Like "[\^$.|?*+()[{]*" Then _
.Pattern = "\" & .Pattern
If .Test(searchSTRING) = True Then
Set MC = .Execute(searchSTRING)
LenFirstInstance = MC(0).Length
End If
End With
End Function
Does this help? I tried it with your sample data and it seemed to work.
Function number_Appearances(ByVal myText As String, ByVal myRng As Range)
Dim cel As Range
Dim txtFound As Boolean
Dim celText$
Dim findText$
findText = myText
Set cel = myRng
celText = cel.Text
Dim celLen&
celLen = Len(celText)
txtFound = True
Dim i&, k&
Dim iChar$
For i = 1 To celLen
iChar = Mid(celText, i, 1)
If iChar = findText And txtFound = True Then
k = k + 1
ElseIf k > 0 And iChar <> findText Then
txtFound = False
End If
Next i
Debug.Print "Found " & k & " " & findText & "'s"
number_Appearances = k
End Function
But I started this before thinking of a formula. #ScottCraner's suggestion is preferable, IMO.
I got off my lazy bum and wrote VBA to solve. Thank you Scott and Bruce. And yes it was 29, not 30. Thank you again.
Public Function count_first_instance_of_consecutive_chars(the_char, the_string)
Dim counter As Integer
Dim iter As Long
Dim is_a_match As Boolean
is_a_match = False
If the_char <> vbNullString And the_string <> vbNullString Then
For iter = 1 To Len(the_string)
If Mid(the_string, iter, 1) = the_char Then
If is_a_match = True Then
counter = counter + 1
ElseIf is_a_match = False Then
is_a_match = True
counter = 1
End If
Else
If is_a_match = True Then
count_first_instance_of_consecutive_chars = counter
Exit For
End If
End If
Next iter
End If
End Function
I have a string which is in A1 of Sheet1 and it refreshes regularly.
it looks like this -
{"rows":[{"advances":637,"declines":836,"unchanged":76,"total":1549}],"success":"true","results":1}
I want to extract numeric values 637 and 836 and 76 and store it in separate columns. The values keeps on changing, like 637 can be sometimes 1200.
I want a VBA code, not an user defined function to automatically extract the numeric data and store it.
I am using this code, but I am not getting anything. What is wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v
End If
Range("=Sheet1!$E$1:$G$1").Copy Destination:=Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1)
Sheets("Updated").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Now
End Sub
While I would be tempted to use standard functions for this you could run a VBA UDF like so
to get the first match from A1 (as a number)
=RegexMatches(A1,1)
the second match
=RegexMatches(A1,2)
and so on
The UDF returns "No Match" where no matches are found, or a message "Less than X matches" if you try to extract a match from a position that doesb't exist
Function RegexMatches(strIn As String, LngPos As Long)
Dim objRegex
Dim objRegexMC
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = ":(\d+),"
If .test(strIn) Then
Set objRegexMC = .Execute(strIn)
If objRegexMC.Count >= LngPos Then
RegexMatches = CLng(objRegexMC(LngPos - 1).submatches(0))
Else
RegexMatches = "Less than " & LngPos & " matches"
End If
Else
RegexMatches = "No Match"
End If
End With
End Function
[Update: added sheet event code]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Set rng1 = Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
'set row1 as first row if it is blank
If rng1.Row = 2 And rng1.Offset(-1, 0) = vbNullString Then Set rng1 = rng1.Offset(-1, 0)
rng1.Resize(1, 3).Value = Range("B1:D1").Value
rng1.Offset(0, -1).Value = Now
End Sub
You can use an instance of the windows script control to parse the text for you:
Sub Tester()
Dim JSON As String
Dim sc As Object
JSON = "{""rows"":[{""advances"":637,""declines"":836," & _
"""unchanged"":76,""total"":1549}]" & _
",""success"":""true"",""results"":1}"
'JSON = ActiveSheet.Range("A1").Value
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.Eval "var o = eval(" & JSON & ")" 'evaluate to an object
Debug.Print "success", sc.Eval("o.success")
Debug.Print "#results", sc.Eval("o.results")
Debug.Print " advances", sc.Eval("o.rows[0].advances")
Debug.Print " declines", sc.Eval("o.rows[0].declines")
Debug.Print " unchanged", sc.Eval("o.rows[0].unchanged")
End Sub
I needed something similar and developed the following code. I have no doubts that it could be made more sophisticated but it provided me with the required result.
Dim cr_ref As String ' Original reference - alpha and numer
Dim new_ref As String ' Resultant numeirc only reference
Dim iAsciiCode As Integer
Dim sCount As Integer ' Length of reference
cr_ref = Trim(Cells(4, 19).Value) ' Get reference from source
sCount = Len(cr_ref)
new_ref = "" ' Start with empty result
For i = 0 To sCount - 1 ' Strip out all except digits
iAsciiCode = Asc(Mid(cr_ref, i + 1, 1)) ' Give me Ascii code
If iAsciiCode >= 48 And iAsciiCode <= 57 Then ' I only want 0-9
new_ref = new_ref & Mid(cr_ref, i + 1, 1) ' Append numeric digit
End If
Next i
' Result is in new_ref
This works:
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v