How to Clean Up This Code

[BikeToWork]

How can I clean up this code? It works but it resembles a plate of spaghetti. Any advice is welcome. The goal of the function is to parse strOrig into Expected Results. Of course strOrig will vary, but will always be in the same format.

Function ParseFolders()
 
Dim strOrig As String
Dim strSemi As String
Dim intSemi As Integer, intSemiBegDoc As Integer
Dim strPipe As String
Dim intPipe As Integer
Dim arTag() As String
Dim arField() As String
Dim arSemi() As Integer
Dim arPipe() As Integer
Dim intLoopCount As Integer, intSecondLoopCount As Integer
Dim strBegDoc As String, strFolder As String
Dim i As Integer, j As Integer, intFieldLen As Integer
Dim strFullString() As String, strDelim As String
 
strDelim = "[delim]"
 
strSemi = ";"
strPipe = "|"
 
strOrig = "AB000001;|Folder01|Tag01|Tag02|;|Folder02|Tag01|Tag03|;"
 
' Expected results: AB000001;Folder01[delim]Tag01;Folder01[delim]Tag02;Folder02[delim]Tag01;Folder02[delim]Tag03
 
 
intSemiBegDoc = InStr(1, strOrig, strSemi)
strBegDoc = Left(strOrig, InStr(intSemiBegDoc, strOrig, strSemi) - 1) & strSemi
 
intSemi = intSemiBegDoc
 
Do While intSemi < Len(strOrig)
    intSemi = InStr(intSemi + 1, strOrig, strSemi)
    intLoopCount = intLoopCount + 1
Loop
 
ReDim arField(intLoopCount - 1)
ReDim arSemi(intLoopCount)
ReDim arField(intLoopCount - 1)
 
intSemi = intSemiBegDoc
 
arSemi(0) = intSemiBegDoc
intSecondLoopCount = 1
 
Do While intSemi < Len(strOrig)
    intSemi = InStr(intSemi + 1, strOrig, strSemi)
    arSemi(intSecondLoopCount) = intSemi
    intSecondLoopCount = intSecondLoopCount + 1
Loop
 
Dim intUbound As Integer
intUbound = UBound(arSemi())
 
For i = 0 To intUbound - 1
    If i < intUbound Then
        arField(i) = Mid(strOrig, arSemi(i) + 1, (arSemi(i + 1) - arSemi(i)))
    Else
        arField(i) = Mid(strOrig, arSemi(i - 1) + 1, arSemi(i))
    End If
Next
 
'Testing for pipes in fields************
 
Dim strTest As String
 
ReDim strFullString(UBound(arField()))
 
 
For j = 0 To UBound(arField())
 
    strTest = arField(j)
 
    intLoopCount = 0
    intPipe = 1
 
    Do While intPipe < Len(strTest) - 1
        intPipe = InStr(intPipe + 1, strTest, strPipe)
        intLoopCount = intLoopCount + 1
    Loop
 
    ReDim arPipe(intLoopCount - 1)
    intUbound = UBound(arPipe())
 
    intLoopCount = 0
 
    intPipe = 1
    Do While intPipe < Len(strTest) - 1
        intPipe = InStr(intPipe + 1, strTest, strPipe)
        arPipe(intLoopCount) = intPipe
        intLoopCount = intLoopCount + 1
    Loop
 
    ReDim arTag(intLoopCount - 2)
    intUbound = UBound(arTag())
 
    strFolder = Left(strTest, arPipe(0))
 
    For i = 0 To intUbound
        If i < intUbound Then
            arTag(i) = Mid(strTest, arPipe(i), (arPipe(i + 1) - arPipe(i) + 1))
        Else
            arTag(i) = Mid(strTest, arPipe(i), Len(strTest) - arPipe(i))
        End If
    Next
 
    If j = 0 Then
        strFullString(j) = strBegDoc
    End If
 
    For i = 0 To intUbound
        strFullString(j) = strFullString(j) & strFolder & strDelim & arTag(i) & strSemi
    Next i
Next j
 
strTest = ""
For i = 0 To UBound(strFullString())
 
    strTest = strTest & strFullString(i)
Next i
 
Debug.Print strTest
 
End Function
 
 
 
 

[zmbd]

Can you provide a sample input and output maybe two or three that covers the expected?

[BikeToWork]

The sample input is: "AB000001;|Folder01|Tag01|Tag02|;|Folder02|Tag01|T ag03|;"

The expected results are:
"AB000001;Folder01[delim]Tag01;Folder01[delim]Tag02;Folder02[delim]Tag01;Folder02[delim]Tag03"

Another sample input is:
"AB000001;|Folder01|Tag01|Tag02|;|Folder02|Tag01|T ag03|;|Folder03|Tag04|Tag05|;"

For this sample the output would be:
"AB000001;|Folder01|[delim]|Tag01|;|Folder01|[delim]|Tag02|;|Folder02|[delim]|Tag01|;|Folder02|[delim]|Tag03|;|Folder03|[delim]|Tag04|;|Folder03|[delim]|Tag05|;"


I am going to substitute a real delimiter for [delim], so that is just a placeholder until we decide which delimiter to use. The input data for this function will be a delimited text file so I'll need to design the database to handle multiple rows.

Thanks for your response.

[zmbd]

I'd use a couple of arrays and the split to handle this...

[zmbd]

Just because you've done a lot of work on the other code... and it has been awhile since I've played with arrays:

In a standard module:

Option Compare Database
Option Explicit
 
Sub splitstring(zstrIn As String)
    Dim zstrArray_pass1() As String
    Dim zstrArray_pass2() As String
    Dim zstrtemp As String
    Dim zstrLeader As String
    Dim zstrParsed As String
    Dim zv As Variant 'this is for the length check
    Dim zi As Integer 'this is for outer loop
    Dim zx As Integer 'this is for inner loop
    Dim zr As Integer 'first pass upper bound
    Dim zc As Integer 'second pass upper bound
    '
    'Parse the initial string based on the semicolon
    zstrArray_pass1 = Split(zstrIn, ";")
    zr = UBound(zstrArray_pass1)
    '
    For zi = 0 To zr
        '
        'Parse each cell in the initial array for the pipe character
        zstrArray_pass2() = Split(zstrArray_pass1(zi), Chr$(124))
        zc = UBound(zstrArray_pass2)
        '
        'Parse the string from the cell by adding it to the string based on length
        For zx = 0 To zc
            If zc > 0 Then
                'check for the value from the cell; setup for null value by zero length string
                zstrtemp = zstrArray_pass2(zx) & ""
                If Len(zstrtemp) Then
                    zv = InStr(1, zstrtemp, "folder")
                    If zv > 0 Then
                        zstrLeader = zstrtemp
                    Else
'>change the deliminator here... I used the percent-sign
                        zstrParsed = zstrParsed & zstrLeader & "%" & zstrtemp & ";"
                    End If
                End If
            Else
                'then this should be the the only value in the cell so append it to the string and clear
                zstrParsed = zstrArray_pass2(0) & ";"
            End If
        Next zx
        '
        'clear the second array for the next cell from the first pass
        ReDim zstrArray_pass2(0)
    Next zi
    Debug.Print String(20, "-")
    Debug.Print zstrParsed
    Debug.Print String(20, "-")
End Sub

In the immediate window (press <ctrl><g>) enter your example:

splitstring("AB000001;|Folder01|Tag01|Tag02|;|Folder02|Tag01|Tag03|;")

Press return and the result will be:

--------------------
AB000001;Folder01%Tag01;Folder01%Tag02;Folder02%Tag01;Folder02%Tag03;
--------------------

Change to a function if you desire.

[BikeToWork]

Thanks, ZMBD. Your code is much less convoluted and more compact than mine and it works.

[zmbd]

It's that Split() function that does the magic.
I used to have a zfncsplitstring() that I coded from back in the old days (prior to ACC2003) that would have added a few more lines! (O_O)
I may still have that around somewhere...
It still used an array, a couple of loops, and the Instr() and Mid() to parse the input string. If I remember correctly, maybe another 10 or 20 lines of code.

[Rabbit]

You can also try regular expressions.

Function test(inputString As String, newDelim As String) As String
    Dim myRegExp, Matches1, Matches2, myMatch2
    Set myRegExp = CreateObject("vbscript.regexp")
    myRegExp.IgnoreCase = True
    myRegExp.Global = True
 
    myRegExp.Pattern = "^([a-z0-9]*);"
    Set Matches1 = myRegExp.Execute(inputString)
    test = Matches1(0)
 
    myRegExp.Pattern = ";\|(([a-z0-9]*)\|)((([a-z0-9]*)\|)*)"
    Set Matches2 = myRegExp.Execute(inputString)
    For Each myMatch2 In Matches2
        myRegExp.Pattern = "([a-z0-9]*)\|"
        test = test & myRegExp.Replace(myMatch2.subMatches(2), myMatch2.subMatches(1) & newDelim & "$1;")
    Next
End Function

Unfortunately the VB Script implementation of regex isn't the most robust so it doubles the code length. Had the implementation been better, it would only be ~8 lines of code or so.

[zmbd]

If you use RegEx in VBA you may need to set the reference to the library.

(opps looks, like Rabbit has that taken careof in line3 with the set>createobject... that'll teach me to read code better)

You will also need to tweek this a tad if you want to remove all of the pipe charaters:

?test("AB000001;|Folder01|Tag01|Tag02|;|Folder02|Tag01|Tag03|;")
'gives the following:
AB000001;Folder01|Tag01;Folder01|Tag02;Folder02|Tag01;Folder02|Tag03;
based in Rabbit's code

[Rabbit]

I've modified my original code to allow for user input of a delimiter.

[BikeToWork]

Rabbit, I really like your regular expression code but cannot get it to work on my computer. I changed the name of the function but not the code inside it.

Function Text1Parse(inputString As String, newDelim As String) As String
    Dim myRegExp, Matches1, Matches2, myMatch2
    Set myRegExp = CreateObject("vbscript.regexp")
    myRegExp.IgnoreCase = True
    myRegExp.Global = True
 
    myRegExp.Pattern = "^([a-z0-9]*);"
    Set Matches1 = myRegExp.Execute(inputString)
    TextParse = Matches1(0)
 
    myRegExp.Pattern = ";\|(([a-z0-9]*)\|)((([a-z0-9]*)\|)*)"
    Set Matches2 = myRegExp.Execute(inputString)
    For Each myMatch2 In Matches2
        myRegExp.Pattern = "([a-z0-9]*)\|"
        TextParse = TextParse & myRegExp.Replace(myMatch2.subMatches(2), myMatch2.subMatches(1) & newDelim & "$1;")
    Next
End Function
 

It errors out on the line "TextParse = Matches1(0)" The runtime error number is 5 and error description is "Invalid Procedure or Argument." Any help with this is much appreciated.

[BikeToWork]

Rabbit, sorry I forgot to include how I am calling the function from the debug window.

TextParse "|Folder01|Tag01|Tag02|;|Folder02|Tag01|Tag03|;|Folder03|Tag04|Tag05|;", "%"

[Rabbit]

Isn't your input wrong? Shouldn't it be:

TextParse "AB000001;|Folder01|Tag01|Tag02|;|Folder02|Tag01|Tag03|;|Folder03|Tag04|Tag05|;", "%"

Also, your function name on line 1 Text1Parse doesn't match your call TextParse.

[BikeToWork]

Sorry for the typos. The function is working properly now. Thanks again for your assistance and thanks to ZMBD.