# Excel VBA Move through String Positions When a Match Found • ### Question

• I have to enter shipment commitment months to a column on a spreadsheet. I derive the month from a commitment streams with comes in the form of 1xS 1x1/1/17 2x2/2/17 3x3/3/17.  The first identifier is the numeric to the left of 1xS.  It would mean 1 in stock. The commitment to delivery that would for quantity 1 on January 1.  The next commitment is for 2 pieces of February 2,etc.,  I have another column that is need quantity.  So if my need quantity is 3, i would want to find the x's after x's, compare their quantity to the need and move on until the need is met and capture the month. In this example would want to display February to meet the need date.  I am getting stuck on looping through the several x's.  Also now getting a run time 13 error.

Sub searchstings()
'9xS  3x02/15 6x02/28
'for i = 2 to
'count rows
Dim i As Integer
Dim StrComplete As String
Dim strCommit As String
Dim strDelvStreamQty As Integer
Dim stock_Pos As Integer
Dim Last_Pos As Integer
Dim strStockEndPos As Integer
Dim Start_Pos As Integer
Dim total As Integer
Dim start_PosSpace As Integer
Dim strR1 As Integer
Dim strR1Value As Integer
Dim strSlashR1Value As String

i = 3 'Start at the second row
Do Until i < 0 'Will never stop unless you get to a blank cell
If IsNull(Worksheets("Sheet1").Cells(i, 2)) Or Len(Worksheets("Sheet1").Cells(i, 2)) = 0 Then
Exit Do
Else
i = i + 1
End If
Loop
total = i - 1
'Debug.Print Total
i = 3

For i = 3 To total + 2
strCommit = Worksheets(1).Cells(39, i).Value '9xS  3x02/15 6x02/28
strDelvStreamQty = Worksheets(1).Cells(11, i).Value 'A number
If strDelvStreamQty <= 0 Then 'if 2
Worksheets(1).Cells(62, i).Value = "" 'No Commit Needed
i = i + 1 'Move to the next i
Else 'A need is present
If Len(strCommit) = 0 Then 'if 1
Worksheets(1).Cells(62, i).Value = "NC" 'No Commit
i = i + 1 'Move to the next i
Else
stock_Pos = InStr(1, strCommit, "xs", vbTextCompare) 'finds stock position of xs
Last_Pos = InStrRev(strCommit, "x", , vbTextCompare) 'finds the last x
strStockEndPos = stock_Pos + 1 'After the s of stock, usually a space
Start_Pos = InStr(strStockEndPos, strCommit, "x", vbTextCompare) 'Finds the first x after stock '6

If Last_Pos = stock_Pos Then 'first x is the also the last one
Worksheets(1).Cells(62, i).Value = "NC" 'No Commit
i = i + 1 'Move to the next i
End If
End If
End If
Do Until StrComplete = True
Start = Start_Pos 'if 4
'For z = Start_Pos To Last_Pos

start_PosSpace = InStrRev(strCommit, " ", Start) 'Finds the last space of the first commit qty
strR1 = Start - start_PosSpace
strR1Value = Mid(strCommit, start_PosSpace, strR1) + strR1Value 'Gets the quantity commited

If strR1Value >= strDelvStreamQty Then 'If the commit is greater than the need 'if 5
startSlash_pos = InStr(Start, strCommit, "/", vbTextCompare) '9
strMonthNumPos = startSlash_pos - Start - 1 '9-6
strSlashR1Value = Mid(strCommit, Start, strMonthNumPos)
Worksheets(1).Cells(62, i).Value = MonthName(strSlashR1Value)
i = i + 1 'Move to the next i
StrComplete = True
End If
strStockEndPos = strStockEndPos + 1
Start_Pos = InStr(strStockEndPos, strCommit, "x", vbTextCompare)
If Start_Pos = 0 Then
Worksheets(1).Cells(62, i).Value = "Partial" 'No Commit
i = i + 1 'Move to the next i
StrComplete = True
End If
Loop

i = i + 1
Next i

End Sub

Saturday, June 24, 2017 9:59 PM

### All replies

• I have to enter shipment commitment months to a column on a spreadsheet. I derive the month from a commitment streams with comes in the form of 1xS 1x1/1/17 2x2/2/17 3x3/3/17.

The first identifier is the numeric to the left of 1xS.  It would mean 1 in stock. The commitment to delivery that would for quantity 1 on January 1.  The next commitment is for 2 pieces of February 2,etc.,

I am getting stuck on looping through the several x's.

I suggest to go a different way, see code below.

Andreas.

```Option Explicit

Sub Main()
Dim S As String
Dim Data, Id

S = "1xS 1x1/1/17 2x2/2/17 3x3/3/17"

'Spit into items
Id = SplitCommitment(S, Data)

'Now you can modify the items directly
Data(1, 1) = 123
Data(1, 2) = DateSerial(2017, 12, 31)

'You can write the data into the sheet, to modify the value there
Range("A1").Resize(UBound(Data), UBound(Data, 2)).Value = Data

'You can read the data back later
Data = Range("A1").CurrentRegion.Value

'And finally build the new commitment string
Debug.Print JoinCommitment(Id, Data)
End Sub

Private Function SplitCommitment(ByVal Expression As String, ByRef Data) As Variant
'Parse a string like "1xS 1x1/1/17 2x2/2/17 3x3/3/17"
'Returns the identifier. Data becomes a 1 based 2D array with Amount/Date in each row
Dim Temp, i As Long, j As Long, k As Long

'Remove double blanks
Expression = Replace(Expression, "  ", " ")
'Split by blanks
Temp = Split(Expression)
'Create space for the output
ReDim Data(1 To UBound(Temp), 1 To 2)
For i = 1 To UBound(Temp)
'Find the "x"
j = InStr(1, Temp(i), "x", vbTextCompare)
'Found?
If j = 0 Then
Err.Raise 5, "SplitCommitment", "Invalid Amount/Date item: " & Temp(i)
End If
'Next row
k = k + 1
'Get the amount
Data(k, 1) = Left(Temp(i), j - 1)
'Convert the real number if possible
If IsNumeric(Data(k, 1)) Then Data(k, 1) = CDbl(Data(k, 1))
'Get the date
Data(k, 2) = Mid(Temp(i), j + 1)
'Convert to real date if possible
If IsDate(Data(k, 2)) Then Data(k, 2) = CDate(Data(k, 2))
Next
'Get the Id (remove "xS" from the end
SplitCommitment = Left(Temp(0), Len(Temp(0)) - 2)
'Convert the real number if possible
If IsNumeric(SplitCommitment) Then SplitCommitment = CDbl(SplitCommitment)
End Function

Private Function JoinCommitment(ByVal Id, ByRef Data) As String
'Returns the commitment string, structure of Data as splitted by SplitCommitment
Dim Temp, i As Long
ReDim Temp(0 To UBound(Data))
Temp(0) = Id & "xS"
For i = 1 To UBound(Data)
Temp(i) = Data(i, 1) & "x" & Data(i, 2)
Next
JoinCommitment = Join(Temp)
End Function
```

Sunday, June 25, 2017 8:26 AM