[Solved] VB-Macros to split two strings and insert them as a new row and trim function

by


Here is one of the solutions:

Prerequisites: Sheet1 contains original data (track# in column A, data to split in column B and comment/date in column C), Sheet2 will contain processed data.

Hope that helps.

The code (click Alt+F11, click Insert/Module, paste the code in the inserted module):

Sub test()
Dim a As String, g As String, k As String, l As String
Dim b As Long, c As Long, d As Integer, e As Integer, f As Long, h As Integer, i As Integer, j As Long
b = 1
j = 1

While IsEmpty(Sheet1.Range("A" & b)) = False 'does not check if exceeding excel row limit
 b = b + 1
Wend

For c = 1 To b 'Or "2 to b" if data has headers (if first row contains column names)
    a = Sheet1.Range("B" & c) 'If column B contains the data to split
    k = Sheet1.Range("A" & c) 'network #
    l = Sheet1.Range("C" & c) 'date or comment
    d = Len(a)
    h = 0
    For e = 1 To d
        If Mid(a, e, 1) = "," Or e = d Then
            If h = 0 Then
                If e = d Then
                    i = e
                Else
                    i = e - 1
                End If
                g = Mid(a, 1, i)
                While IsEmpty(Sheet2.Range("B" & j)) = False 'does not check if exceeding excel row limit
                    j = j + 1
                Wend
                Sheet2.Range("A" & j) = k
                Sheet2.Range("B" & j) = g
                Sheet2.Range("C" & j) = l
            Else
                If e = d Then
                    g = Mid(a, i + 2, e - i - 1)
                Else
                    g = Mid(a, i + 2, e - i - 2)
                End If
                While IsEmpty(Sheet2.Range("B" & j)) = False 'does not check if exceeding excel row limit
                    j = j + 1
                Wend
                Sheet2.Range("A" & j) = k
                Sheet2.Range("B" & j) = g
                Sheet2.Range("C" & j) = l

                i = e - 1

            End If
            h = 1
        End If
    Next e
Next c

Dim m As Long, o As Integer
m = 1 'Or 2 if top row contains headings
Dim n As String
While IsEmpty(Sheet2.Range("B" & m)) = False
    Sheet2.Range("B" & m) = Trim(Sheet2.Range("B" & m)) 'trim
    n = Sheet2.Range("B" & m)
    For o = 1 To Len(n)
        If Mid(n, o, 1) = " " Then n = Left(n, 1) & Right(n, Len(n) - 2) 'remove single space
    Next o
    Sheet2.Range("B" & m) = n
    m = m + 1
Wend

End Sub

Try this code (Update according to the comments):

Sub test()

Dim srow As Integer

srow = MsgBox("Does the first row contain data headers (column names)?", vbYesNo + vbQuestion, "First row selection")
If srow = 6 Then
    srow = srow - 4
Else
    srow = srow - 6
End If

Dim a As String, g As String, k(16383) As String, l(16383) As String
Dim b As Long, c As Long, d As Integer, e As Integer, f As Long, h As Integer, i As Integer, j As Long
b = srow
j = srow

While IsEmpty(Sheet1.Range("A" & b)) = False And b < 1048576
    b = b + 1
Wend

b = b - 1

If srow > b Then MsgBox "No entries to analyze!", vbInformation, "Attention!": Exit Sub

Dim spli As String

INPU:
spli = InputBox("Please, enter the Letter of the column, which contains the data to split", "Define split column")

If Len(spli) > 3 Or Len(spli) < 1 Then MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU

Dim letc As Integer

For letc = 65 To 122
    If letc <> 91 And letc <> 92 And letc <> 93 And letc <> 94 And letc <> 95 And letc <> 96 Then
        If Left(spli, 1) = Chr(letc) Then Exit For
        If letc = 122 And Left(spli, 1) <> Chr(letc) Then MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
    End If
Next letc

If Len(spli) > 1 Then
    For letc = 65 To 122
        If letc <> 91 And letc <> 92 And letc <> 93 And letc <> 94 And letc <> 95 And letc <> 96 Then
            If Mid(spli, 2, 1) = Chr(letc) Then Exit For
            If letc = 122 And Mid(spli, 2, 1) <> Chr(letc) Then MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
        End If
    Next letc
End If

If Len(spli) = 3 Then
    For letc = 65 To 122
        If letc <> 91 And letc <> 92 And letc <> 93 And letc <> 94 And letc <> 95 And letc <> 96 Then
            If Right(spli, 1) = Chr(letc) Then Exit For
            If letc = 122 And Right(spli, 1) <> Chr(letc) Then MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
        End If
    Next letc

    If Left(spli, 1) = "Y" Or Left(spli, 1) = "Z" Or Left(spli, 1) = "y" Or Left(spli, 1) = "z" Then
        MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
    End If
    If Left(spli, 1) = "X" Or Left(spli, 1) = "x" Then
        If Asc(Mid(spli, 2, 1)) < 65 Or (Asc(Mid(spli, 2, 1)) > 70 And Asc(Mid(spli, 2, 1)) < 97) Or Asc(Mid(spli, 2, 1)) > 102 Then
            MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
        End If
        If Mid(spli, 2, 1) = "F" Or Mid(spli, 2, 1) = "f" Then
            If Asc(Right(spli, 1)) < 65 Or (Asc(Right(spli, 1)) > 68 And Asc(Right(spli, 1)) < 97) Or Asc(Right(spli, 1)) > 100 Then
                MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
            End If
        End If
    End If
End If

Dim coll As Long, colr As Long, coun As Long

RECL:
coll = InputBox("How many columns to the left of the split data column would you like to copy?", "Left Columns")

If Sheet1.Range(spli & srow).Column - coll < 1 Then
    MsgBox "Wrong number of columns indicated", vbExclamation + vbOKOnly, "Error!"
    GoTo RECL
End If

RECR:
colr = InputBox("How many columns to the right of the split data column would you like to copy?", "Right Columns")

If Sheet1.Range(spli & srow).Column + colr > 16384 Then
    MsgBox "Wrong number of columns indicated", vbExclamation + vbOKOnly, "Error!"
    GoTo RECR
End If

For c = srow To b
    a = Sheet1.Range(spli & c)
    For coun = 0 To coll - 1
        k(coun) = Sheet1.Cells(c, Sheet1.Range(spli & c).Column - 1 - coun)
    Next coun
    For coun = 0 To colr - 1
        l(coun) = Sheet1.Cells(c, Sheet1.Range(spli & c).Column + 1 + coun)
    Next coun

    d = Len(a)
    h = 0
    For e = 1 To d
        If Mid(a, e, 1) = "," Or Mid(a, e, 1) = "https://stackoverflow.com/" Or e = d Then
            If h = 0 Then
                If e = d Then
                    i = e
                Else
                    i = e - 1
                End If
                g = Mid(a, 1, i)
                While IsEmpty(Sheet2.Range(spli & j)) = False And j < 1048576
                    j = j + 1
                Wend
                For coun = 0 To coll - 1
                     Sheet2.Cells(j, Sheet1.Range(spli & c).Column - 1 - coun) = k(coun)
                Next coun
                Sheet2.Range(spli & j) = g
                For coun = 0 To colr - 1
                     Sheet2.Cells(j, Sheet1.Range(spli & c).Column + 1 + coun) = l(coun)
                Next coun
            Else
                If e = d Then
                    g = Mid(a, i + 2, e - i - 1)
                Else
                    g = Mid(a, i + 2, e - i - 2)
                End If
                While IsEmpty(Sheet2.Range(spli & j)) = False And j < 1048576
                    j = j + 1
                Wend
                For coun = 0 To coll - 1
                     Sheet2.Cells(j, Sheet1.Range(spli & c).Column - 1 - coun) = k(coun)
                Next coun
                Sheet2.Range(spli & j) = g
                For coun = 0 To colr - 1
                     Sheet2.Cells(j, Sheet1.Range(spli & c).Column + 1 + coun) = l(coun)
                Next coun

                i = e - 1

            End If
            h = 1
        End If
    Next e
Next c

Dim m As Long, o As Integer
m = srow
Dim n As String
While IsEmpty(Sheet2.Range(spli & m)) = False
    Sheet2.Range(spli & m) = Trim(Sheet2.Range(spli & m)) 'trim
    n = Sheet2.Range(spli & m)
    For o = 1 To Len(n)
        If Mid(n, o, 1) = " " Then n = Left(n, 1) & Right(n, Len(n) - 2) 'remove single space
    Next o
    Sheet2.Range(spli & m) = n
    m = m + 1
Wend

End Sub

13

solved VB-Macros to split two strings and insert them as a new row and trim function