Will write spaces but not the last character (VBA Excel)

Question

DATA:

DESIRED OUTPUT:

CURRENT OUTPUT:

MY CURRENT CODE:

Private Sub GenerateFlatFile_Click()
Dim myFile As String, rng As Range, cellValue As Variant, I As Integer, j As Integer, SpacingCode As String

Dim iPar As Integer
Dim sBlank As Long
Dim cont As Boolean
Dim mystring As String

myFile = "C:\Reformatted.txt"
Set rng = Selection

Open myFile For Output As #1

Dim strArr(1 To 63) As String, intBeg As Integer, intEnd As Integer, intCount As Integer, sChar As String

For I = 2 To rng.Rows.Count
    For j = 1 To rng.Columns.Count
        If InStr(1, CStr(Cells(1, j).Value), "63") = 1 Then
            strArr(Val(Cells(1, j).Value)) = Cells(I, j).Value
        ElseIf InStr(1, CStr(Cells(1, j).Value), "Code") Then

                iPar = InStr(1, CStr(Cells(I, j).Value), "(")
                If Mid(Cells(I, j).Value, iPar - 1, 1) = "" Then
                    If Mid(Cells(I, j).Value, iPar - 2, 1) = "" Then
                    sChar = Mid(Cells(I, j).Value, iPar - 3, 1)
                    Else: sChar = Mid(Cells(I, j).Value, iPar - 4, 1)
                    End If
                Else: sChar = Mid(Cells(I, j).Value, iPar - 2, 1)
                End If
                If IsNumeric(Mid(Cells(I, j).Value, iPar + 1, 2)) Then
                    sBlank = Mid(Cells(I, j).Value, iPar + 1, 2)
                Else: sBlank = Mid(Cells(I, j).Value, iPar + 1, 1)
                End If
                mystring = Space(sBlank) & sChar
                cont = InStr(iPar + 1, CStr(Cells(I, j).Value), "(")

            Do While cont = True

                iPar = InStr(iPar + 1, CStr(Cells(I, j).Value), "(")
                If Mid(Cells(I, j).Value, iPar - 1, 1) = "" Then
                    If Mid(Cells(I, j).Value, iPar - 2, 1) = "" Then
                    sChar = Mid(Cells(I, j).Value, iPar - 3, 1)
                    Else: sChar = Mid(Cells(I, j).Value, iPar - 2, 1)
                    End If
                Else: sChar = Mid(Cells(I, j).Value, iPar - 1, 1)
                End If
                If IsNumeric(Mid(Cells(I, j).Value, iPar + 1, 2)) Then
                    sBlank = Mid(Cells(I, j).Value, iPar + 1, 2)
                Else: sBlank = Mid(Cells(I, j).Value, iPar + 1, 1)
                End If

                If sBlank + 1 > Len(mystring) Then
                    mystring = mystring & Space(sBlank - Len(mystring)) & sChar
                Else: mystring = Application.WorksheetFunction.Replace(mystring, sBlank + 1, 1, sChar)
                End If
                cont = InStr(iPar + 1, CStr(Cells(1, j).Value), "(")

            Loop

        ElseIf InStr(1, CStr(Cells(1, j).Value), "Difference") Then
            SpacingCode = Space(rng.Cells(I, j))
        Else
        intBeg = Val(Left(Cells(1, j).Value, InStr(1, Cells(1, j).Value, "-") - 1))
        intEnd = Val(Right(Cells(1, j).Value, Len(Cells(1, j).Value) - InStr(1, Cells(1, j).Value, "-")))
        intCount = 1
        For t = intBeg To intEnd
            strArr(t) = Mid(Cells(I, j).Value, intCount, 1)
            intCount = intCount + 1
        Next t
        End If
    Next j
    For t = 1 To UBound(strArr)
        If strArr(t) = "" Then strArr(t) = " "
        cellValue = cellValue + strArr(t)
    Next t
    Erase strArr
    cellValue = cellValue + SpacingCode
    cellValue = cellValue + mystring
    Print #1, cellValue
    cellValue = ""
Next I

Close #1
Shell "C:\Windows\Notepad.exe C:\Reformatted.txt", 1
End Sub

I've been trying for awhile but when there is TWO spaces between the ( and the letter it doesnt seem to work.

F and G works since there is only 1 space. Only when there is multiple letter codes or two spaces it doesn't work. Thanks for your time!

Answer 1

It seems your problem is merely with the last column. Here is a UDF, using regular expression that will

• Search a string
• look for any "word" (sequence of letters, digits, and/or underscores) followed by zero or more spaces and then an open parentheses mark (
• combine those word sequences into a space separated string

You should be able to incorporate this into your code.

If you provide more detail as to the possible types of codes, the regex might be altered, but the above seems to fit.

=================================================

Function Codes(S As String) As String
    Dim RE As Object, MC As Object, M As Object

Set RE = CreateObject("vbscript.regexp")
With RE
    .Global = True
    .Pattern = "\b(\w+)\s*\("
    If .test(S) = True Then
        Set MC = RE.Execute(S)
        For Each M In MC
            Codes = Codes & Space(1) & M.submatches(0)
        Next M
    End If
End With
Codes = Mid(Codes, 2)
End Function

=================================================