none
Excel VBA Move through String Positions When a Match Found RRS feed

  • 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