I have 6 sheets in an Excel document.
I would like to compare two sheets.
Sheet 1 (Artikelstammdaten) has 8555 Lines
Sheet 2 (Warengruppen) has 232 Lines
My Code:
Sub WorksheetLoop()
Dim Current As Range
Dim Element As Range
Dim wgRow As Integer
Dim wbRow As Integer
Dim Warengruppe As String
Dim Warengruppebezeichnung As String
Dim Stamm1 As String
Dim Stamm2 As String
Dim Stamm3 As String
Dim Summe As String
wgRow = 2
wbRow = 2
For Each Element In Sheets("Artikelstammdaten").Range("R:R")
Warengruppebezeichnung = Sheets("Warengruppen").Cells(wbRow, 1).Value
Warengruppe = Sheets("Artikelstammdaten").Cells(wgRow, 18).Value
If Warengruppe = Warengruppebezeichnung Then
Stamm1 = Sheets("Warengruppen").Cells(wbRow, 2).Value
Stamm2 = Sheets("Warengruppen").Cells(wbRow, 3).Value
Stamm3 = Sheets("Warengruppen").Cells(wbRow, 4).Value
Summe = Stamm1 + ">" + Stamm2 + ">" + Stamm3
Sheets("Artikelstammdaten").Cells(wgRow, 18).Value = Summe
wbRow = 2
wgRow = wgRow + 1
Else
wbRow = wbRow + 1
End If
Next
End Sub
It works but breaks off at line 1755.
The reason you got only 1755 iterations is that you waste many loops to find the matching value in Sheets("Warengruppen"). Use a wiser way, Range.Find(What:=key) method returns a range object with the same key. Note it will return Nothing if nothing is matched, so we need to check if it is found or not for preventing an error.
Sub WorksheetLoop()
'current is crying because you never call her :/
Dim Current As Range
Dim Element As Range
Dim wbFound As Range
Dim Stamm1 As String
Dim Stamm2 As String
Dim Stamm3 As String
Dim Summe As String
For Each Element In Sheets("Artikelstammdaten").Range("R:R")
Set wbFound = Sheets("Warengruppen").Range("A:A").Find(What:=Element.Value)
If wbFound Is Nothing Then
Debug.Print "Not Found with Row# " & Element.Row
Else
Stamm1 = wbFound.Offset(0, 1)
Stamm2 = wbFound.Offset(0, 2)
Stamm3 = wbFound.Offset(0, 3)
Summe = Stamm1 + ">" + Stamm2 + ">" + Stamm3
Element.Value = Summe
End If
Next Element
End Sub
Related
I have the follow code to fill cells in excel one by one and it works the way I want it to but it gives me this error when it runs through the array. How do I fix this error? Thanks
The error is "Subscript out of range. Error: 9"
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
Cells(i, 1) = finalSplit(0)
Cells(i, 2) = finalSplit(1)
Cells(i, 3) = finalSplit(2)
Cells(i, 4) = finalSplit(3)
i = i + 1
s = s + 1
Next
I checked if finalSplit contains enough values like Thomas said and it worked.This is the new code below.
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
If UBound(finalSplit) > 1 Then
Cells(i, 1) = finalSplit(0)
Cells(i, 2) = finalSplit(1)
Cells(i, 3) = finalSplit(2)
Cells(i, 4) = finalSplit(3)
i = i + 1
s = s + 1
End If
Next
As other commenters have pointed out, why not add another control variable?
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
Dim i As Integer, j As Integer, s As Integer
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
For j = 0 To UBound(finalSplit)
Cells(i, j + 1) = finalSplit(j)
Next j
i = i + 1
s = s + 1
Next
Be aware that this can loop more than the 4 times you expect. A lazy way to solve this would be to add If j > 3 Then Exit For before Next j
I tested this with the following code (it works!), as I have no idea what splitString() or finalSplit() is in your case:
Sub test()
Dim finalSplit As Variant
Dim j As Integer
finalSplit = Split("1,2,3,4,5", ",")
For j = 0 To UBound(finalSplit)
Cells(1, j + 1) = finalSplit(j)
If j > 3 Then Exit For
Next j
End Sub
Looping Through Elements of Arrays
An array created by the Split function is always 0-based (even if Option Base 1). Similarly, not quite related, an array created by the Array function is dependent on Option Base unless you use its parent VBA e.g. arr = VBA.Array(1,2,3). Then it is always zero-based.
Looping through the elements of an array (1D array) is done in the following two ways:
For Each...Next
Dim Item As Variant
For Each Item In Arr
Debug.Print Item
Next Item
For...Next
Dim i As Long
For i = LBound(Arr) To Ubound(Arr)
Debug.Print Arr(i)
Next i
Since we have established that Split always produces a zero-based array, in the second example we could use 0 instead of LBound(Arr):
`For...Next`
Dim i As Long
For i = 0 To Ubound(Arr)
Debug.Print Arr(i)
Next i
Option Explicit
Sub DoubleSplit()
Const IniString As String = "A,B,C,D/E,F,G,H/I,J,K/L/M,N,O,P,Q,R"
Dim SplitString() As String: SplitString = Split(IniString, "/")
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
ws.Cells.ClearContents ' remove previous data; clears the whole worksheet
Dim FinalSplit() As String
Dim Item As Variant ' SplitString Control Variable
Dim r As Long ' Worksheet Row Counter
Dim f As Long ' FinalSplit Element Counter
' For Each...Next
For Each Item In SplitString
r = r + 1
FinalSplit = Split(Item, ",")
Debug.Print Join(FinalSplit, ",")
For f = 0 To UBound(FinalSplit)
ws.Cells(r, f + 1).Value = FinalSplit(f)
Next f
Next Item
r = r + 1 ' add an empty row
Dim s As Long ' SplitString Element Counter
' For...Next
For s = 0 To UBound(SplitString)
r = r + 1
FinalSplit = Split(SplitString(s), ",")
Debug.Print Join(FinalSplit, ",")
For f = 0 To UBound(FinalSplit)
ws.Cells(r, f + 1).Value = FinalSplit(f)
Next f
Next s
' Results
' A,B,C,D
' E,F,G,H
' I,J,K
' L
' M,N,O,P,Q,R
'
' A,B,C,D
' E,F,G,H
' I,J,K
' L
' M,N,O,P,Q,R
End Sub
Excel spreadsheet
I have a set of over 10,000 lines of text strings in column A (Input), and I need to get the number (in case there is only one) or a sum of both (in case there are two).
Code
Here is the VBA code I have:
Sub ExtractNumericStrings()
Dim rngTemp As Range
Dim strTemp As String
Dim currNumber1 As Currency
Dim currNumber2 As Currency
Dim lngTemp As Long
Dim lngPos As Long
Dim lngLastRow As Long
With ActiveSheet
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rngTemp In .Cells(1, "A").Resize(lngLastRow, 1) ' Set Range to look at
strTemp = rngTemp.Value2 ' Get string value of each cell
lngTemp = Len(strTemp) 'Get length of string
currNumber1 = 0 ' Reset value
currNumber2 = 0 ' Reset value
' Get first number
currNumber1 = fncGetNumericValue(strTemp, 1) ' Strip out first number
' Get second number if exists
' First strip out first number
strTemp = Replace(strTemp, currNumber1, "")
If Len(strTemp) <> 0 Then
currNumber2 = fncGetNumericValue(strTemp, 1)
End If
' now paste to sheet
If currNumber1 <> 0 And currNumber2 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1 + currNumber2
rngTemp.Offset(0, 2).Value = "sum of the numbers"
ElseIf currNumber1 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1
End If
Next rngTemp
End With
Call MsgBox("Procedure Complete!", vbOKOnly + vbInformation, "Procedure Complete")
End Sub
Private Function fncGetNumericValue(strTemp As String, lngStart As Long) As Currency
Dim varTemp As Variant
Dim lngCount As Long
Dim lngTemp As Long
' Reset
lngCount = 1
lngTemp = 1
varTemp = ""
On Error Resume Next
If IsNumeric(Left(strTemp, lngCount)) Then
Do While IsNumeric(Left(strTemp, lngCount)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
Else
' First clear non-numerics from string
lngTemp = 1
Do While IsNumeric(Left(strTemp, 1)) = False
lngTemp = lngTemp + 1
strTemp = Mid(strTemp, 2, Len(strTemp) - 1)
If lngTemp > Len(strTemp) Then
Exit Do
End If
Loop
' Then extract second number if exists
If strTemp <> "" Then
Do While IsNumeric(Mid(strTemp, lngCount, 1)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
End If
End If
' Retrun Value
If IsNumeric(varTemp) Then
fncGetNumericValue = CCur(varTemp)
Else
fncGetNumericValue = 0
End If
End Function
Here is what I'm trying to do:
https://www.youtube.com/watch?v=EjHnJVxuWJA
I have very limited knowledge of VBA, so please excuse me if I ask any stupid question. Running this thing successfully will save me hips of time. thanks!
Something like this:
Private Sub extract_num()
Dim cell as Range
Dim ws as Worksheet: Set ws = Sheets("Sheet1") ' replace Sheet1 with ur sheet name
Dim lr as Long: Set lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim values() As String
Dim i as Byte
Dim temp as Double
For Each cell in ws.Range("A2:A" & lr)
If Not isEmpty(cell) Then
values = Split(cell, " ")
For i = LBound(values) to UBound(values)
values(i) = Replace(values(i), ",", ".")
If isNumeric(values(i)) Then
temp = temp + values(i)
End If
Next i
cell.Offset(0, 2) = temp
temp = 0
End If
Next cell
End Function
This is presuming:
a) Individual words and numbers are always separated by space "123 abc 321"
b) Commas "," are used as an arithmetic floatpoint separator ##,##
Slightly different approach from Rawrplus
Option Explicit
Sub UpdateTotals()
Dim aRawValues As Variant
Dim iLRow&, iRow&, iArr&
Dim dTotal#
With ThisWorkbook.Worksheets("Sheet1") '<-- Change the sheet name to your sheet
iLRow = .Cells(Rows.Count, 1).End(xlUp).Row ' Get row count
For iRow = 1 To iLRow ' Loop through all rows in the sheet
aRawValues = Split(.Range("A" & iRow).Value, " ") ' Create and array of current cell value
For iArr = LBound(aRawValues) To UBound(aRawValues) ' Loop through all values in the array
dTotal = dTotal + ReturnDouble(Replace(aRawValues(iArr), ",", ".")) ' Add the returned double to total
Next
.Range("B" & iRow).Value = dTotal ' Set value in column B
dTotal = 0# ' Reset total
Next
End With
End Sub
Function ReturnDouble(ByVal sTextToConvert As String) As Double
Dim iCount%
Dim sNumbers$, sCurrChr$
sNumbers = ""
For iCount = 1 To Len(sTextToConvert)
sCurrChr = Mid(sTextToConvert, iCount, 1)
If IsNumeric(sCurrChr) Or sCurrChr = "." Then
sNumbers = sNumbers & sCurrChr
End If
Next
If Len(sNumbers) > 0 Then
ReturnDouble = CDbl(sNumbers)
Else
ReturnDouble = 0#
End If
End Function
I don't know how to search for this or how to explain without an example.
I'm looking for an excel function that compares cell strings and identifies the portion they have in common.
Conditions
Compares 2 or more cells.
The common string is identified as long as 2 cells share it. *(ie: if comparing more than 2, it's enough to have 2 cells with that string. Not all the compared cells need to have it.) *
The string has at least 3 or more chars to avoid single characters and pairs being flagged.
Example
----------------------------------------------------------------------
| Pattern | Page URL 1 | Page URL 2 | Page URL 3 |
----------------------------------------------------------------------
| test | example.net/test/ | www.test.com | www.notest.com |
----------------------------------------------------------------------
| q=age | another.com?q=age | test.com/q=age | test.com/q=lol |
----------------------------------------------------------------------
Probably obvious by now, but what I'm trying to achieve/analyze is if there are string patterns that are common to large sets of URLs.
(forgive my poor attempt trying to draw a table)
This doesn't fully answer the question but I think it will give you what you need to get it. Give it a try. Place the following code in a new moudule:
Public Sub FindStrings()
Dim rng1 As Excel.Range
Dim rng2 As Excel.Range
Set rng1 = ActiveSheet.Range("A1")
Set rng2 = ActiveSheet.Range("A2")
Dim i As Integer
Dim j As Integer
Dim searchVal As String
For i = 3 To Len(rng2)
For j = 1 To Len(rng1)
searchVal = Mid(rng1, j, i)
If Len(searchVal) < i Then Exit For
If InStr(1, rng2, searchVal) Then Debug.Print searchVal
Next j
Next i
End Sub
In cell A1 put example.net/test
In cell A2 put www.test.com
Result
tes
est
test
UPDATE
I updated the code to search for a minimum of 4 characters instead of 3 (as you mentioned above). Furthermore, I guessed you wouldn't want strings such as www. and .com returned, nor strings with the / or . character. So the code pulls those out as well. Also, it compares every column combination.
Option Explicit
Public Sub CompareStrings()
Dim Arr As Variant
Dim i As Integer
Dim j As Integer
Dim StartRange As Excel.Range
Dim SearchRange As Excel.Range
Dim Counter As Integer
Dim ComparableRange As Variant
Dim Comparable As Integer
Dim Compared As Integer
Dim SearchVal As String
Set StartRange = ActiveSheet.Range("A1")
Counter = 0
For Each ComparableRange In ActiveSheet.Range("A1:A2")
Set SearchRange = Range(StartRange.Offset(Counter), Cells(StartRange.Offset(Counter).Row, Columns.Count).End(xlToLeft))
Arr = Application.Transpose(Application.Transpose(SearchRange.Value))
Debug.Print "Row " & SearchRange.Row & ":"
For j = LBound(Arr) To UBound(Arr)
For i = j + 1 To UBound(Arr)
For Comparable = 4 To Len(Arr(j))
For Compared = 1 To Len(Arr(i))
SearchVal = Mid(Arr(j), Compared, Comparable)
If InStr(1, SearchVal, ".") = 0 Then
If InStr(1, SearchVal, "/") = 0 Then
If Len(SearchVal) < Comparable Then Exit For
If InStr(1, Arr(i), SearchVal) > 0 Then Debug.Print vbTab & SearchVal
End If
End If
Next Compared
Next Comparable
Next i
Next j
Counter = Counter + 1
Next ComparableRange
End Sub
When comparing test.com/q=age with another.com?q=age You will still get results such as:
q=ag
=age
q=age
...though I suspect you only want the third one. The longer the matching strings are the more results you will get. The last results are the ones you will probably want.
Copy the following code into a module. Read the comments at the top of CommonString for usage.
Option Explicit
Public Function CommonString(rng As Range, iMinLen As Integer, Optional strDelimiter As String = ",") As String
'Finds the maximum number of cells (iMax) in "rng" that have a common substring of length at least "iMinLen".
'The function returns a string with the format "iMax: substring1,substring2,substring3..."
' where substring1, substring2, etc. are unique substrings found in exactly iMax cells.
'The output does not include any substrings of the unique substrings.
'The delimter between substrings can be specified by the optional parameter "strDelimiter".
'If no common substrings of length at least "iMinLen" are found, "CommonString" will return an empty string.
Dim blnRemove() As Boolean
Dim dicSubStrings As Object 'records the number of times substrings are found in pairwise string comparisons
Dim iCandidates As Integer
Dim iCol As Integer
Dim iCurrCommon As Integer
Dim iCurrLen As Integer
Dim iMax As Integer
Dim iMaxCommon As Integer
Dim iNumStrings As Integer
Dim iOutCount As Integer
Dim iRow As Integer
Dim iString1 As Integer
Dim iString2 As Integer
Dim iSubStr1 As Integer
Dim iSubStr2 As Integer
Dim lngSumLen As Long
Dim str1D() As String
Dim strCandidates() As String
Dim strOut() As String
Dim strSim() As String
Dim strSub As String
Dim vKey As Variant
Dim vStringsIn() As Variant
Set dicSubStrings = CreateObject("Scripting.Dictionary")
vStringsIn = rng.Value
iNumStrings = Application.CountA(rng)
ReDim str1D(1 To iNumStrings)
' pull the strings into a 1-D array
For iRow = 1 To UBound(vStringsIn, 1)
For iCol = 1 To UBound(vStringsIn, 2)
iCurrLen = Len(vStringsIn(iRow, iCol))
If iCurrLen > 0 Then
iString1 = iString1 + 1
str1D(iString1) = vStringsIn(iRow, iCol)
lngSumLen = lngSumLen + iCurrLen
End If
Next iCol
Next iRow
'initialize the array that will hold the substrings to output
ReDim strOut(1 To lngSumLen - iNumStrings * (iMinLen - 1))
'find common substrings from all pairwise combination of strings
For iString1 = 1 To iNumStrings - 1
For iString2 = iString1 + 1 To iNumStrings
strSim = Sim2Strings(str1D(iString1), str1D(iString2), iMinLen)
'loop through all common substrings
For iSubStr1 = 1 To UBound(strSim)
If dicSubStrings.Exists(strSim(iSubStr1)) Then
iCurrCommon = dicSubStrings(strSim(iSubStr1)) + 1
dicSubStrings(strSim(iSubStr1)) = iCurrCommon
If iCurrCommon > iMaxCommon Then iMaxCommon = iCurrCommon
Else 'add common substrings to the "dicSubStrings" dictionary
dicSubStrings.Add strSim(iSubStr1), 1
If iMaxCommon = 0 Then iMaxCommon = 1
End If
Next iSubStr1
Next iString2
Next iString1
If dicSubStrings.Count = 0 Then Exit Function
ReDim strCandidates(1 To dicSubStrings.Count)
'add the candidate substrings to the "strCandidates" array
'candidate substrings are those found in exactly "iMaxCommon" pairwise comparisons
For Each vKey In dicSubStrings.keys
If dicSubStrings(vKey) = iMaxCommon Then
iCandidates = iCandidates + 1
strCandidates(iCandidates) = CStr(vKey)
End If
Next vKey
ReDim blnRemove(1 To iCandidates)
iOutCount = iCandidates
'keep only the candidate substrings that are not a substring within another candidate substring
For iSubStr1 = 1 To iCandidates - 1
If Not blnRemove(iSubStr1) Then
For iSubStr2 = 1 To iCandidates - 1
If Not blnRemove(iSubStr2) Then
If Len(strCandidates(iSubStr1)) <> Len(strCandidates(iSubStr2)) Then
If Len(strCandidates(iSubStr1)) > Len(strCandidates(iSubStr2)) Then
If InStr(strCandidates(iSubStr1), strCandidates(iSubStr2)) > 0 Then
blnRemove(iSubStr2) = True
iOutCount = iOutCount - 1
End If
Else
If InStr(strCandidates(iSubStr2), strCandidates(iSubStr1)) > 0 Then
blnRemove(iSubStr1) = True
iOutCount = iOutCount - 1
End If
End If
End If
End If
Next iSubStr2
End If
Next iSubStr1
ReDim strOut(1 To iOutCount)
iOutCount = 0
'add the successful candidates to "strOut"
For iSubStr1 = 1 To iCandidates
If Not blnRemove(iSubStr1) Then
iOutCount = iOutCount + 1
strOut(iOutCount) = strCandidates(iSubStr1)
End If
Next iSubStr1
'convert "iMaxCommon" (pairwise counts) to number of cells (iMax) by solving the formula:
'(iMax ^ 2 - iMax) / 2 = iMaxCommon
iMax = ((8 * iMaxCommon + 1) ^ 0.5 + 1) / 2
CommonString = iMax & ": " & Join(strOut, strDelimiter)
End Function
Private Function Sim2Strings(str1 As String, str2 As String, iMinLen As Integer) As String()
'Returns a list of unique substrings common to both "str1" and "str2" that
' have a length of at least "iMinLen".
Dim dicInList As Object
Dim iCharFrom As Integer
Dim iLen1 As Integer
Dim iSearchLen As Integer
Dim iSubStr As Integer
Dim strCurr As String
Dim strList() As String
Dim vKey As Variant
iLen1 = Len(str1)
Set dicInList = CreateObject("Scripting.Dictionary")
'add common substrings to the "dicInList" dictionary
For iCharFrom = 1 To iLen1 - iMinLen + 1
For iSearchLen = iMinLen To iLen1 - iCharFrom + 1
strCurr = Mid(str1, iCharFrom, iSearchLen)
If InStr(str2, strCurr) = 0 Then
Exit For
Else
If Not dicInList.Exists(strCurr) Then
dicInList.Add strCurr, 0
End If
End If
Next iSearchLen
Next iCharFrom
If dicInList.Count = 0 Then
ReDim strList(0)
Else
ReDim Preserve strList(1 To dicInList.Count)
'output the keys in the "dicInList" dictionary to the "strList" array
For Each vKey In dicInList.keys
iSubStr = iSubStr + 1
strList(iSubStr) = vKey
Next vKey
End If
Sim2Strings = strList
End Function
The below Code Counts the number of unique names is a specific column after inputting the data into an array. It works perfectly when running in the the immediate window. But when using as a UDF it throws #Value Error. I am taking all the data into an array and checking the array and getting a number out of it and returning it. I am not modifying any excel sheets or changing the worksheet's environment. Please help!!1
Public Function Operator_Count(Aircraft As String) As Integer
Dim Aircraft_Name As String
Dim Data_Array() As Variant
Dim Row_Count As Integer
Dim Col_Count As Integer
Dim Col_Alph As String
Dim Row_Counter As Integer
Dim Master_Series_Column As Integer
Dim Status_Column As Integer
Dim Operator_Column As Integer
Dim InnerLoop_Counter As Integer
Dim Operator_Array() As Variant
Dim Operator_Array_Transpose() As Variant
Dim Array_Counter As Integer
Aircraft_Name = Aircraft
Operator_Count = 0
'ThisWorkbook.Sheets("Aircraft Data").Activate
Row_Count = ThisWorkbook.Sheets("Aircraft Data").Range("A2", Range("A2").End(xlDown)).Rows.Count
Col_Count = ThisWorkbook.Sheets("Aircraft Data").Cells(1, Columns.Count).End(xlToLeft).Column
Col_Alph = ColumnLetter(Col_Count)
Data_Array = ThisWorkbook.Sheets("Aircraft Data").Range("A1:" & Col_Alph & Row_Count + 1).Value2
For Row_Counter = 1 To Col_Count
If Data_Array(1, Row_Counter) = "Master Series" Then
Master_Series_Column = Row_Counter
End If
Next
For Row_Counter = 1 To Col_Count
If Data_Array(1, Row_Counter) = "Status" Then
Status_Column = Row_Counter
End If
Next
For Row_Counter = 1 To Col_Count
If Data_Array(1, Row_Counter) = "Operator" Then
Operator_Column = Row_Counter
End If
Next
'Resizing the data array
ReDim Operator_Array(0, 0)
'Adding column to the data array
InnerLoop_Counter = 0
For Row_Counter = 1 To UBound(Data_Array)
If Data_Array(Row_Counter, Master_Series_Column) = Aircraft_Name And (Data_Array(Row_Counter, Status_Column) = "In Service" Or Data_Array(Row_Counter, Status_Column) = "On order") Then
Flag = 0
For Array_Counter = 0 To UBound(Operator_Array, 2)
If Operator_Array(0, Array_Counter) = Data_Array(Row_Counter, Operator_Column) Then
Flag = 1
Array_Counter = UBound(Operator_Array, 2)
End If
Next
If Flag <> 1 Then
ReDim Preserve Operator_Array(0, InnerLoop_Counter)
Operator_Array(0, InnerLoop_Counter) = Data_Array(Row_Counter, Operator_Column)
InnerLoop_Counter = InnerLoop_Counter + 1
End If
End If
Next
Operator_Count = UBound(Operator_Array, 2)
End Function
Function ColumnLetter(ColumnNumber As Integer) As String
Dim n As Integer
Dim c As Byte
Dim s As String
n = ColumnNumber
Do
c = ((n - 1) Mod 26)
s = Chr(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
ColumnLetter = s
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