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

BalloutMoe

New Member
Joined
Jun 4, 2021
Messages
41
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.
 

BalloutMoe

New Member
Joined
Jun 4, 2021
Messages
41
Office Version
  1. 365
Platform
  1. Windows
:oops: Try this one.

VBA Code:
Sub GetData_v2()
  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 = "^([^ ]+)( )([^ ]+)( )([^ ]+ )([^ ]+)( )(.+)( )([^ ]+)( )([^ ]+)$"
  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 s Like "#*.* #*.* EA * #*.* #*.*#"
            k = k + 1
            a(k, 1) = RX.Replace(s, "$1;$3;$6;$8;$10;$12")
            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
1623182405605.png


Everything is working great just under itemID, sometimes the pattern has a space between for example MFP CAF2174C so its splitting it with the description. Anyway around that by any chance?
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
928
Office Version
  1. 2010
Platform
  1. Windows
What is your logic to separate the ID and the description ?​
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
49,095
Office Version
  1. 365
Platform
  1. Windows
sometimes the pattern has a space between for example MFP CAF2174C
Do you mean sometimes the pattern does not have a space between ..?
If so, how do we decide where a split should occur?
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
928
Office Version
  1. 2010
Platform
  1. Windows
Ok, according to the attachment from the source text file the logic is obvious so very not an issue to separate any column …​
But comparing this source text file and your result workbook : whow ! What is the logic, why so few rows ?​
So I very need to understand what are the criterias from the source text file to obtain the same workbook result …​
 

BalloutMoe

New Member
Joined
Jun 4, 2021
Messages
41
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Do you mean sometimes the pattern does not have a space between ..?
If so, how do we decide where a split should occur?
It has an extra space after the id
1623194723747.png

MFPTC2055 is an item ID number so is MFPCAF2174C but sometimes there is a space between MPC and CAF2174C so it does not take the number. I would like to have item ID to be anything before the word MIGHTY or DRAIN.
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
928
Office Version
  1. 2010
Platform
  1. Windows
Have you read at least post #24 ?​
 

BalloutMoe

New Member
Joined
Jun 4, 2021
Messages
41
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Have you read at least post #24 ?​
Sorry you posted that right as I was posting my comment. I’ll be back by the laptop in 15 minutes. I will post exactly what is happening. Thank you
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
49,095
Office Version
  1. 365
Platform
  1. Windows
I would like to have item ID to be anything before the word MIGHTY or DRAIN.
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
 
Solution

BalloutMoe

New Member
Joined
Jun 4, 2021
Messages
41
Office Version
  1. 365
Platform
  1. Windows
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
Thank you again, I tried this code it works better then the one before but it is still skipping over some for some reason.
1​
1​
MFPA90100MIGHTYAIR FILTER EA$ 9.95$ 9.95
2​
2​
MFPA90097MIGHTYAIR FILTER EA$ 6.99$ 13.98
1​
1​
MFPA90096MIGHTYAIR FILTER EA$ 9.95$ 9.95
1​
1​
MFPA6911MIGHTYAIR FILTER EA$ 9.95$ 9.95
1​
1​
MFPA3590MIGHTYAIR FILTER EA$ 7.99$ 7.99
1​
1​
MFPA4048MIGHTYAIR FILTER EA$ 6.99$ 6.99
2​
2​
MFPCAF2152 MIGHTY CABINAIR FILTER$ 9.95$ 19.90
2​
2​
MFPCAF2161 MIGHTY CABINAIR FITLER$ 9.95$ 19.90
1​
1​
MFPCAF2145C MIGHTY CABINAIR FILTER$ 10.99$ 10.99
2​
2​
MFPCAF2139 MIGHTY CABINAIR FILTER$ 9.95$ 19.90
1​
1​
MFPCAF2135 MIGHTY CABINAIR FILTER$ 13.95$ 13.95
1​
1​
MFPTC2131MIGHTY TEC SELECT CABIN AIR FILTER$ 6.50$ 6.50
2​
2​
MFPTC2130MIGHTY TECSELECT CABIN AIR FILTER$ 8.85$ 17.70
2​
2​
MFPTC2127MIGHTY TEC SELECT CABIN AIR FILTER$ 7.75$ 15.50
1​
1​
MFPTC2122MIGHTY TECSELECT CABIN AIR FILTER$ 5.99$ 5.99
1​
1​
MFPCAF2104 MIGHTY CABINAIR FILTER$ 10.95$ 10.95
4​
4​
MFPCAF2084 MIGHTY CABINAIR FILTER$ 9.95$ 39.80
1​
1​
MFPCAF2086 MIGHTY CABINAIR FILTER$ 12.95$ 12.95
2​
2​
MFPTC2090MIGHTY TECSELECT CABIN AIR FILTER$ 5.99$ 11.98
1​
1​
MFPCAF2097 MIGHTY CABINAIR FILTER$ 8.25$ 8.25
1​
1​
MFPTC1766MIGHTY TECSELECT CABIN AIR FILTER$ 4.99$ 4.99

As you can see still some part numbers are still being put in the description. MFP should also include the part number. Which is MFPCAF2152, MFPCAF2161. It is much better the V2
 

BalloutMoe

New Member
Joined
Jun 4, 2021
Messages
41
Office Version
  1. 365
Platform
  1. Windows
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
I tried RX.Pattern = "^([^ ]+)( )([^ ]+)( )(EA )(.+?)( )(MIGHTY( )|DRAIN)(.+)( )([^ ]+)( )([^ ]+)$" adding a space after the "MIGHTY" it works and takes all the Item ID but the description now is only MIGHTY OR DRAIN
 

Watch MrExcel Video

Forum statistics

Threads
1,132,935
Messages
5,656,002
Members
418,264
Latest member
Reiper79

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
Top