I have a column in "dd-mm-yy hh:mm" format that formed as a result of some action on UserForm:
Dim ws as Worksheet
Set ws = Worksheets("Logs")
With ws
For i = 1 to Me.ListBox1.ListCount - 1
.Cells(lRow + 1 + i, 10).Value = CDate(VBA.Format(Me.ListBox1.List(i), "dd-mm-yy hh:mm"))
Next i
End With
I save the column to Variant variable to use later (to be used multiple times):
Dim arrTimeD As Variant
arrTimeD = Application.Transpose(.Range(TCL & "2:" & TCL & lRow).Value)
The locale date settings are European: "dd-mmm-yyyy"
The spreadsheet are used by different users, some have "dd-mmm" setting, others "mm-dd" etc.
I need to compare the dates in several uses. For, e.g.
Dim bDate as Date
bDate = CDate(VBA.Format(Me.lblCheckin.Caption,"dd-mm-yyyy"))
Do While CDate(arrTimeD(bIndex)) < bDate
If bIndex = lRow - 1 Then Exit Do
bIndex = bIndex + 1
Loop
When the user with US locale ("mm-dd") uses the spreadsheet, CDate(arrTimeD(bIndex)) throws error. CDate(VBA.Format(arrTimeD(bIndex))) and CDate(DateValue(arrTimeD(bIndex)) didn't help. What is the best way to do it?
Is it possible to set workbook's own date setting regardless of OS's?
Or I need to convert variant to string then concatenate?
The date string should be converted into a numeric date value.
Function DDMMYYYFormatToDateTimeValue(DateString As String) As Date
Dim Parts() As String
Parts = Split(DateString, "-")
DDMMYYYFormatToDateTimeValue = CDate(Parts(1) & "/" & Parts(0) & "/" & Parts(2))
End Function
Usage
Private Sub UserForm_Initialize()
Dim n As Long
For n = 1 To 100
ListBox1.AddItem Format(Date + n / 24, "MM-DD-YY HH:MM")
Next
End Sub
Public Function ListBoxDateValues()
Dim Data As Variant
ReDim Data(1 To Me.ListBox1.ListCount, 1 To 1)
Dim DateString As String
Dim r As Long
For r = 1 To Me.ListBox1.ListCount
DateString = Me.ListBox1.List(r - 1)
Data(r, 1) = DDMMYYYFormatToDateTimeValue(DateString)
Next
ListBoxDateValues = Data
End Function
Public Function wsLogs() As Worksheet
Set wsLogs = ThisWorkbook.Sheets("Logs")
End Function
Function DDMMYYYFormatToDateTimeValue(DateString As String) As Date
Dim Parts() As String
Parts = Split(DateString, "-")
DDMMYYYFormatToDateTimeValue = CDate(Parts(1) & "/" & Parts(0) & "/" & Parts(2))
End Function
First, true date values carry no format, so convert your text dates from the listbox directly to true date values:
.Cells(lRow + 1 + i, 10).Value = CDate(Me.ListBox1.List(i))
These you can apply the format you prefer for display.
The comparison is now straight:
Dim bDate As Date
bDate = CDate(Me.lblCheckin.Caption)
Do While arrTimeD(bIndex) < bDate
If bIndex = lRow - 1 Then
Exit Do
Else
bIndex = bIndex + 1
End If
Loop
Related
I created a lookup function that finds the result from a separate tab within the same worksheet with 4 different fields to match.
When running, this takes entirely too long to complete (to the point where I have to kill the macro run). I need to build the same lookup function for 8 different fields, based on the exact same match criteria. Any advice on how to speed up this query or build it in a more dynamic way, so I can lookup all 8 columns at once rather than building functions and subs for each lookup field?
Function fcst_bal_find(ByVal Anode As String, ByVal LoB As String, ByVal Month As String, ByVal Year As String) As Variant
Dim Fcst_Essbase As Worksheet
Dim fcst_rowcnt
Dim act_rowcnt
fcst_rowcnt = Sheets("Date Dims").Range("B7")
act_rowcnt = Sheets("Date Dims").Range("B8")
Set Fcst_Essbase = Sheets("Fcst Essbase Pull")
For i = 2 To fcst_rowcnt + 4
If WorksheetFunction.Trim(Fcst_Essbase.Cells(i, 1).Value) = Anode Then
If WorksheetFunction.Trim(Fcst_Essbase.Cells(i, 2).Value) = LoB Then
If WorksheetFunction.Trim(Fcst_Essbase.Cells(i, 3).Value) = Month Then
If "Y" & Right(WorksheetFunction.Trim(Fcst_Essbase.Cells(i, 4).Value), 2) = Year Then
fcst_bal_find = Fcst_Essbase.Cells(i, 5).Value
Exit Function
End If
End If
End If
End If
Next i
fcst_bal_find = "N/A"
End Function
Sub balfcst_find()
Dim fcst_tab As Worksheet
Dim match As Variant
Dim Anode As String
Dim LoB As String
Dim Month As String
Dim Year As String
Dim fcst_rowcnt
Dim act_rowcnt
fcst_rowcnt = Sheets("Date Dims").Range("B7")
act_rowcnt = Sheets("Date Dims").Range("B8")
Set fcst_tab = Sheets("Cartesian Product - Fcst")
For i = 2 To fcst_rowcnt
Anode = fcst_tab.Range("A" & i).Value
LoB = fcst_tab.Range("B" & i).Value
Month = fcst_tab.Range("C" & i).Value
Year = fcst_tab.Range("D" & i).Value
match = fcst_bal_find(Anode, LoB, Month, Year)
fcst_tab.Cells(i, 5) = match ' test the output
Next i
End Sub
Here is an example of using variant array to match something from a current project of mine. You can modify to suit your needs.
Private Function verifyMod(modValue As Double, state As String) As Boolean
If Len(modValue) Then
Dim modTable As ListObject
Set modTable = lookupsAUState.ListObjects("stateWritingCoModMinMax")
Dim v As Variant
v = modTable.DataBodyRange.value
Dim company As String
company = StrConv(xmlCo.Range("insuranceCompanyName"), vbProperCase)
Dim x As Long
For x = LBound(v) To UBound(v)
If v(x, modTable.ListColumns("Company").index) = company Then
If v(x, modTable.ListColumns("State").index) = state Then
If modValue >= v(x, modTable.ListColumns("Min").index) And modValue <= v(x, modTable.ListColumns("Max").index) Then
verifyMod = True
Else
MsgBox state & " allows for modifications between " & v(x, modTable.ListColumns("Min").index) & " and " & v(x, modTable.ListColumns("Max").index) & ". Please enter a modification within that range."
End If
Exit For
End If
End If
Next
End If
End Function
Receiving an error when I run the code below. This worked last month, just seemed to stop working since I performed an update on Octobers data.
The script should grab data from Derek_Calc, which is a list of all logins on a daily basis to an application on the server. This data is then compressed to highlight how many people are logging in per hour on any given day.
The following line is used to set the date information for where the data will be added to the table and the dates for which to check in the DEREK_Calcs:
Set tempRange = target1.Range("B1706:B1736")
Sub PopulateConcurrency() 'for re-populating specific dates for the 'DEREK_Concurrency_Logins' sheet
'UPDATE THE DATE RANGE below!
Dim thisBook As Workbook
Dim target1 As Worksheet
Dim target2 As Worksheet
Dim dbSheetNames(1 To 2) As String
Dim cell As Variant
Dim cell2 As Variant
Dim searchDate As String
Dim firstColDate As Boolean
Dim userIdLoginCount As Long
Dim startHour As String
Dim endHour As String
Dim startDateTime As Date
Dim endDateTime As Date
Dim startDateHour As Date
Dim endDateHour As Date
Dim hourCounter As Integer
Dim startRange As Range
Dim endRange As Range
Dim tempString As String
Dim counter As Long
Dim userIds() As Long
Dim uniqueIds As Collection, c
Dim targCellRange As Range
Dim tempRange As Range
Dim tempRange2 As Range
dbSheetNames(1) = "DEREK_Concurrency_Logins"
dbSheetNames(2) = "DEREK_Calcs"
Set thisBook = ThisWorkbook
Set target1 = thisBook.Sheets(dbSheetNames(1))
Set target2 = thisBook.Sheets(dbSheetNames(2))
'prepare variables
userIdLoginCount = 0
hourCounter = 0
'de-activate re-calculations for this sheet as these will be updated later
target1.EnableCalculation = False
target2.EnableCalculation = False
'stop screen refreshing
Application.ScreenUpdating = False
Set tempRange = target1.Range("B1706:B1736") 'UPDATE THE DATE RANGE FROM COLUMN B Of THE 'DEREK_Concurrency_Logins' sheet
For Each cell In tempRange 'loop through each date in the DEREK_Concurrency_User_Logins sheet
searchDate = cell.Value
searchDate = Format(searchDate, "dd/mm/yyyy")
firstColDate = True
hourCounter = 0
For hourCounter = 0 To 16 'loop to next hour time range
'get start hour and end hour
startHour = target1.Cells(2, (3 + hourCounter))
startHour = Format(startHour, "hh:mm")
endHour = target1.Cells(2, (4 + hourCounter))
endHour = Format(endHour, "hh:mm")
'prepare variables
Erase userIds
Set uniqueIds = Nothing
Set uniqueIds = New Collection
userIdLoginCount = 0
counter = 0
With target2
Set tempRange2 = target2.Range("DEREK_LoginDaily")
For Each cell2 In tempRange2 'loop through each cell2 In DEREK_LoginDaily
If (StrComp(searchDate, cell2.Value) = 0) Then 'check for date match
If firstColDate = False Then
Set startRange = cell2
Set endRange = cell2
'get start and end hours for the hour period
startDateTime = startRange.Offset(0, 7).Value
endDateTime = endRange.Offset(0, 8).Value
'get the login start and finish times
tempString = Day(startDateTime) & "/" & Month(startDateTime) & "/" & Year(startDateTime) & " " & Format(startHour, "hh:mm")
startDateHour = CDate(tempString)
tempString = Day(endDateTime) & "/" & Month(endDateTime) & "/" & Year(endDateTime) & " " & Format(endHour, "hh:mm")
endDateHour = CDate(tempString)
If startDateTime <= startDateHour And endDateTime >= endDateHour Then
Sheets(dbSheetNames(2)).Select
startRange.Offset(0, 10).Select
startRange.Offset(0, 10).Activate
ReDim Preserve userIds(counter)
If (startRange.Offset(0, 10).Length > 0) Then
If startRange.Offset(0, 6).Value = 1 Then
userIds(counter) = startRange.Offset(0, 10).Value
End If
End If
counter = counter + 1 'increment counter
End If 'end hour concurency check
Else 'if firstColDate is True
startHour = target1.Cells(2, 2) 'code for 7am - 8am, set startHour to 07:00
endHour = target1.Cells(2, 4) 'set endHour to 08:00
Set startRange = cell2
Set endRange = cell2
'get start and end hours for the hour period
startDateTime = startRange.Offset(0, 7).Value
endDateTime = endRange.Offset(0, 8).Value
'get the login start and finish times
tempString = Day(startDateTime) & "/" & Month(startDateTime) & "/" & Year(startDateTime) & " " & Format(startHour, "hh:mm")
startDateHour = CDate(tempString)
tempString = Day(endDateTime) & "/" & Month(endDateTime) & "/" & Year(endDateTime) & " " & Format(endHour, "hh:mm")
endDateHour = CDate(tempString)
If startDateTime <= startDateHour And endDateTime >= endDateHour Then
Sheets(dbSheetNames(2)).Select
'THIS IS WHERE THE ERROR IS :-(
startRange.Offset(0, 10).Select
startRange.Offset(0, 10).Activate
ReDim Preserve userIds(counter)
If (startRange.Offset(0, 10).Length > 0) Then
If startRange.Offset(0, 6).Value = 1 Then
userIds(counter) = startRange.Offset(0, 10).Value
End If
End If
counter = counter + 1 'increment counter
End If 'end hour concurency check
End If 'end if firstColDate
End If 'end if a date match
Next cell2 'loop through each cell2 In DEREK_LoginDaily
End With
'get unique values by putting array into a collection
On Error Resume Next
For Each c In userIds
If Not IsEmpty(c) Then
uniqueIds.Add Item:=c, Key:=CStr(c)
End If
Next c
'populate target cell
Set targCellRange = cell
targCellRange.Offset(0, (2 + hourCounter)) = (uniqueIds.count)
firstColDate = False
Next hourCounter 'loop to next hour time range
firstColDate = True
Next cell 'loop through each date in the DEREK_Concurrency_User_Logins sheet
MsgBox "Complete"
End Sub
Not sure how, but this line is where the issue is:
startRange.Offset(0, 10).Length > 0
For a Range option you cannot have a length. I received some help and changed the line to this:
Len(startRange.Offset(0, 10).Value)
This is now populating correctly. The entire scripts job is to take a worksheet of data including login dates and times, and then populate another table detailing how many users were in the system on an hourly basis.
Thank you for the help everyone!
Excelfile
Hello I have an excel files with time stamps in a row as shown in the image
I want to calculate the difference and enter the value in a new column. I tried the following code but it shows a type mismatch error and I don't know why.
I know its easy, but I'm new to VBA so please help me.
\\Sub macro1()
Dim i As Integer
Dim j As Integer
Dim k As Integer
i = 1
j = 2
k = 2
Do While Cells(i, 1).Value <> ""
Cells(k, 2).Value = Cells(j, 1).Value - Cells(i, 1).Value
i = i + 1
j = i + 1
k = i
Loop
End Sub
Your format (2.10.2017 08:08:30) should be manipulated before using CDate to convert the cell value into a date, then use the VBA function DateDiff. See below. Put =timeDiff(A2,A1) in B2, then copy to B3 and down. Below is the VBA code.
Public Function transformCellStrInDate(ByVal rng As Range) As Date
Dim splitArr As Variant, dateArr As Variant, dateStr As String
splitArr = Split(Trim(rng.Value))
dateArr = Split(splitArr(0), ".")
dateStr = dateArr(0) & "/" & dateArr(1) & "/" & dateArr(2) & " " & splitArr(1)
transformCellStrInDate = CDate(dateStr)
Erase dateArr: Erase splitArr
End Function
Public Function timeDiff(ByVal rngY As Range, ByVal rngX As Range) As Long
timeDiff = DateDiff("n", transformCellStrInDate(rngX), transformCellStrInDate(rngY)) / 60 ' in Hours
End Function
I have this dates from DB and I want to fix the date in VBA excel because excel switch the date with month when filter the column
27/08/2018
31/08/2018
12/9/2018
2/8/2018 wrong date reported at filter in excel need 02/08/2018
6/8/2018 wrong date reported at filter in excel need 06/08/2018
13/08/2018
17/08/2018
20/08/2018
20/08/2018
I have tried this
For i = 2 To lastRow
Dim fDate As Date
Dim dayF As String
Dim monthF As String
Dim yearF As String
Set r = Cells(i, Column_DateStamp)
strDate = Split(r.Text, "/")
dayF = CStr(Format(strDate(0), "00"))
monthF = CStr(Format(strDate(1), "00"))
yearF = CStr(Format(strDate(2), "0000"))
fDate = Format(DateSerial(strDate(2), CStr(Format(strDate(1), "00")), CStr(Format(strDate(0), "00"))), "dd/mm/yyyy")
r.Clear
r.Value = fDate
Next i
The date formats do not match your local date format and as such Excel is trying to convert.
You need to either put the date in and format it appropriately or make the cell text so excel does not try to convert.
Dim i As Long
For i = 2 To lastRow
Dim fDate As Date
Dim r As Range
Set r = Cells(i, Column_DateStamp)
strDate = Split(r.Text, "/")
fDate = DateSerial(strDate(2), strDate(1), strDate(0))
r.Clear
'True date - comment out if you want string
r.NumberFormat = "dd/mm/yyyy"
r.Value2 = fDate
'String - Uncomment if you want string
' r.NumberFormat = "#"
' r.Value2 = Format(fDate, "dd/mm/yyyy")
Next i
Examining your screenshot, the problem is consistent with your Windows Regional Settings being MDY and the Database settings being DMY. This will always result in incorrect action by Excel.
Whoever wrote the ERP application should be able to make the change to input, to Excel, an unambiguous date format; or trigger the excel text import wizard at the time of import.
You can try this macro in the meantime. It should work, but read the notes carefully for possible pitfalls:
Option Explicit
Sub ConvertDates()
'converts dates that have been mismatched MDY / DMY
'Assumes dates are all in selected column
' Only need to select a single cell in the column
' will place results in a column next to original data
' If adjacent column is not blank, a column will be inserted
'Figures out the original format by analyzing a "text" date
'Time components are converted directly. This might be OK unless
' in a non standard format such as 1400Z
Dim R As Range, C As Range
Dim sDelim As String
Dim FileDateFormat As String * 3
Dim i As Long, j As Long, V As Variant
Dim vDateParts As Variant
Dim YR As Long, MN As Long, DY As Long
Dim TM As Double
Dim vRes As Variant 'to hold the results of conversion
Set R = Selection
'Test that selected cell contains a date
If Not IsDate(R(1)) Then
MsgBox "Select a cell containing a date"
Exit Sub
End If
Set R = Intersect(R.EntireColumn, ActiveSheet.UsedRange)
ReDim vRes(1 To R.Rows.Count, 1 To 1)
'Find a "text date" cell to analyze
For Each C In R
With C
If IsDate(.Value) And Not IsNumeric(.Value2) Then
'find delimiter
For i = 1 To Len(.Text)
If Not Mid(.Text, i, 1) Like "#" Then
sDelim = Mid(.Text, i, 1)
Exit For
End If
Next i
'split off any times
V = Split(.Text & " 00:00")
vDateParts = Split(V(0), sDelim)
If vDateParts(0) > 12 Then
FileDateFormat = "DMY"
Exit For
ElseIf vDateParts(1) > 12 Then
FileDateFormat = "MDY"
Exit For
Else
MsgBox "cannot analyze data"
Exit Sub
End If
End If
End With
Next C
If sDelim = "" Then
MsgBox "cannot find problem"
Exit Sub
End If
'Check that analyzed date format different from Windows Regional Settings
Select Case Application.International(xlDateOrder)
Case 0 'MDY
If FileDateFormat = "MDY" Then
MsgBox "File Date Format and Windows Regional Settings match" & vbLf _
& "Look for problem elsewhere"
Exit Sub
End If
Case 1 'DMY
If FileDateFormat = "DMY" Then
MsgBox "File Date Format and Windows Regional Settings match" & vbLf _
& "Look for problem elsewhere"
Exit Sub
End If
End Select
'Process dates
'Could shorten this segment but probably more understandable this way
j = 0
Select Case FileDateFormat
Case "DMY"
For Each C In R
With C
If IsDate(.Value) And IsNumeric(.Value2) Then
'Reverse the day and the month
YR = Year(.Value2)
MN = Day(.Value2)
DY = Month(.Value2)
TM = .Value2 - Int(.Value2)
ElseIf IsDate(.Value) And Not IsNumeric(.Value2) Then
V = Split(.Text & " 00:00") 'remove the time
vDateParts = Split(V(0), sDelim)
YR = vDateParts(2)
MN = vDateParts(1)
DY = vDateParts(0)
TM = TimeValue(V(1))
Else
YR = 0
End If
j = j + 1
If YR = 0 Then
vRes(j, 1) = C.Value
Else
vRes(j, 1) = DateSerial(YR, MN, DY) + TM
End If
End With
Next C
Case "MDY"
For Each C In R
With C
If IsDate(.Value) And IsNumeric(.Value2) Then
'Reverse the day and the month
YR = Year(.Value2)
MN = Day(.Value2)
DY = Month(.Value2)
TM = .Value2 - Int(.Value2)
ElseIf IsDate(.Value) And Not IsNumeric(.Value2) Then
V = Split(.Text & " 00:00") 'remove the time
vDateParts = Split(V(0), sDelim)
YR = vDateParts(2)
MN = vDateParts(0)
DY = vDateParts(1)
TM = TimeValue(V(1))
Else
YR = 0
End If
j = j + 1
If YR = 0 Then
vRes(j, 1) = C.Value
Else
vRes(j, 1) = DateSerial(YR, MN, DY) + TM
End If
End With
Next C
End Select
With R.Offset(0, 1).EntireColumn
Set C = .Find(what:="*", LookIn:=xlFormulas)
If Not C Is Nothing Then .EntireColumn.Insert
End With
R.Offset(0, 1).Value = vRes
End Sub
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