Excel VBA Parse Column A into multiple columns help but with conditions

BalloutMoe

Board Regular
Joined
Jun 4, 2021
Messages
137
Office Version
  1. 365
Platform
  1. Windows
Hello, I have a TXT file that gets imported in excel and it always ends up in column A. I am trying to split the data up however. The middle columns with text usually vary. For example

1.000 1.000 EA MWPTS16 MIGHTY 16in TecSelect WIPER BLADE EA 1.9900 1.99
1.000 1.000 EA MWPTS18 MIGHTY 18in TecSelect WIPER BLADE EA 1.9900 1.99
1.000 1.000 EA MWPTS21 MIGHTY 21in TecSelect WIPER BLADE EA 1.9900 1.99
1.000 1.000 EA MLE 9012LL MIGHTY HIR2/12V LONG LIFE HALOGEN 16.9800 16.98
EA
1.000 1.000 EA MLE H11-55W MIGHTY HALOGEN HEADLAMP EA 7.9500 7.95
4.000 4.000 EA MSL 80-39 MIGHTY DRAIN PLUG EA 4.9500 19.80
1.000 1.000 EA MFPTC2064 MIGHTY TECSELECT CABIN AIR FILTER 5.4900 5.49
EA

I would like to split like this: 1.000 | 1.000 EA | rest of the text here | Then 1.9900 | 1.99. Ending up with 5 columns. However the length of the text varies every time. So if I split them normally some number won't be inline with each other. Can this be done in any specific way. Or any way to guide me get started.
 
Never mind it works now. After running it a few times now it works. THANK YOU is their a way I can contribute something for your help. AMAZING WORK
 
Upvote 0

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
According to your last attachment a VBA basics demonstration to paste to the Sheet1 worksheet module :​
VBA Code:
Sub Demo1()
  Const E = " EA  ", S = "  "
    Dim V, F%, R&, L&
        V = Application.GetOpenFilename("Text files,*.txt"):  If V = False Then Exit Sub
        UsedRange.Offset(1).Clear
        F = FreeFile
        Open V For Input As #F
        V = Filter(Split(Input(LOF(F), #F), vbCrLf), E, True)
        Close #F
    For R = 0 To UBound(V)
        F = 0
        L = -1
        While F < 3:  F = F + 1:  L = InStrRev(V(R), S, L):  Wend
        V(R) = Replace(Replace(Left(V(R), L - 1), E, vbTab, , 1), S, vbTab, , 2) & Replace(V(R), S, vbTab, L, 3)
    Next
        Application.ScreenUpdating = False
    With [A2].Resize(R)
        .Value2 = Application.Transpose(V)
        .TextToColumns , 1, , , True, , , , , , , "."
        .Columns("C:D").AutoFit
    End With
        Application.ScreenUpdating = True
End Sub
 
Upvote 0
According to your last attachment a VBA basics demonstration to paste to the Sheet1 worksheet module :​
VBA Code:
Sub Demo1()
  Const E = " EA  ", S = "  "
    Dim V, F%, R&, L&
        V = Application.GetOpenFilename("Text files,*.txt"):  If V = False Then Exit Sub
        UsedRange.Offset(1).Clear
        F = FreeFile
        Open V For Input As #F
        V = Filter(Split(Input(LOF(F), #F), vbCrLf), E, True)
        Close #F
    For R = 0 To UBound(V)
        F = 0
        L = -1
        While F < 3:  F = F + 1:  L = InStrRev(V(R), S, L):  Wend
        V(R) = Replace(Replace(Left(V(R), L - 1), E, vbTab, , 1), S, vbTab, , 2) & Replace(V(R), S, vbTab, L, 3)
    Next
        Application.ScreenUpdating = False
    With [A2].Resize(R)
        .Value2 = Application.Transpose(V)
        .TextToColumns , 1, , , True, , , , , , , "."
        .Columns("C:D").AutoFit
    End With
        Application.ScreenUpdating = True
End Sub
Thank you I will give this a go as well
 
Upvote 0
According to your last attachment a VBA basics demonstration to paste to the Sheet1 worksheet module :​
VBA Code:
Sub Demo1()
  Const E = " EA  ", S = "  "
    Dim V, F%, R&, L&
        V = Application.GetOpenFilename("Text files,*.txt"):  If V = False Then Exit Sub
        UsedRange.Offset(1).Clear
        F = FreeFile
        Open V For Input As #F
        V = Filter(Split(Input(LOF(F), #F), vbCrLf), E, True)
        Close #F
    For R = 0 To UBound(V)
        F = 0
        L = -1
        While F < 3:  F = F + 1:  L = InStrRev(V(R), S, L):  Wend
        V(R) = Replace(Replace(Left(V(R), L - 1), E, vbTab, , 1), S, vbTab, , 2) & Replace(V(R), S, vbTab, L, 3)
    Next
        Application.ScreenUpdating = False
    With [A2].Resize(R)
        .Value2 = Application.Transpose(V)
        .TextToColumns , 1, , , True, , , , , , , "."
        .Columns("C:D").AutoFit
    End With
        Application.ScreenUpdating = True
End Sub
I get a runtime error 1004 "Application-defined or object-defined error"
 
Upvote 0
OK, try this

VBA Code:
Sub GetData_v3()
  Dim RX As Object
  Dim a As Variant
  Dim sFile As String, s As String, InvNo As String
  Dim k As Long
  Dim bInv As Boolean
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Pattern = "^([^ ]+)( )([^ ]+)( )(EA )(.+?)( )(MIGHTY|DRAIN)(.+)( )([^ ]+)( )([^ ]+)$"
  sFile = Application.GetOpenFilename()
  If sFile <> "False" Then
    Open sFile For Input As #1
    ReDim a(1 To Rows.Count, 1 To 1)
    Do Until EOF(1)
        Line Input #1, s
        s = Application.Trim(s)
        Select Case True
          Case s = "INVOICE"
            bInv = True
          Case bInv And IsNumeric(Left(s, 1)) And s <> InvNo
            k = k + 1
            a(k, 1) = "Inv: " & s
            InvNo = s
            bInv = False
          Case RX.Test(s)
            k = k + 1
            a(k, 1) = RX.Replace(s, "$1;$3;$6;$8$9;$11;$13")
            bInv = False
          Case Else
            bInv = False
        End Select
    Loop
    Close #1
    Sheets.Add
    With Range("A2").Resize(k)
      .Value = a
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
      .Resize(, 6).Rows(0).Value = Array("Ordered", "Shipped", "Item ID", "Item Description", "Unit Price", "Ext price")
      .Resize(, 6).EntireColumn.AutoFit
    End With
  End If
End Sub
Can I add multiple patterns to this line? In some cases I have another style invoice which is very similar but uses CS instead of each. Can I have them be on the same RX.pattern?
"^([^ ]+)( )([^ ]+)( )(EA )(.+?)( )(MIGHTY|DRAIN)(.+)( )([^ ]+)( )([^ ]+)$"
can I add this to the above code? If so how would I implement it. I tried a few things but with no results. Thank you
"^([^ ]+)( )([^ ]+)( )(CS)(.+?)( )(MIGHTY|DRAIN)(.+)( )([^ ]+)( )([^ ]+)$"
 
Upvote 0
I tried or but it did not work
"^([^ ]+)( )([^ ]+)( )(EA )(.+?)( )(MIGHTY|DRAIN)(.+)( )([^ ]+)( )([^ ]+)$" or "^([^ ]+)( )([^ ]+)( )(CS)(.+?)( )(MIGHTY|DRAIN)(.+)( )([^ ]+)( )([^ ]+)$"
 
Upvote 0
I figured it out but one more problem...never ends lol
"^([^ ]+)( )([^ ]+)( )(EA |CS |GL |)(.+?)( )(MIGHTY|DRAIN)(.+)( )([^ ]+)( )([^ ]+)$" this is what worked.
however one of the "MIGHTY" Conditions contains a (K) before it
"^([^ ]+)( )([^ ]+)( )(EA |CS |GL |)(.+?)( )(MIGHTY|DRAIN|(K)MIGHTY)(.+)( )([^ ]+)( )([^ ]+)$" but this is not working I am assuming because of the () around the K anyway around that?
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,952
Members
448,535
Latest member
alrossman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top