split excel cell using vbscript

Question

GIVEN: Using VBScript, I am trying to rearrange the way data is presented in an excel document. I know that the data will always be in the following format:

       A      |               B              |  C  |  D  
--------------|------------------------------|-----|-----
1 ANGLE       | 6 x 3-1/2 x 5-16 x 240       |  1  | C1054
2 SQAURE TUBE | 1-1/2 x 1-1/2 x 1/8 x 31-3/4 |  3  | C1588
3 DOM TUBE    | 5-1/2 OD x 1" WALL           |  4  | C1670

GOAL: My goal is to get it into this format:

                 A                |    B    |  C  |   D
----------------------------------|---------|-----|-------
1 6 X 3-1/2 X 5-16 ANGLE          | 240     |  1  | C1054
2 1-1/2 X 1-1/2 X 1/8 SQAURE TUBE | 31-3/4  |  3  | C1588
3 5-1/2 OD X 1" WALL DOM TUBE     |         |  4  | C1670

My idea is to first insert blank columns between columns B and C. Then, I will use the split command to break up column B with little "x" where this intermediate step will look like:

       A      |     B    |    C    |   D  |    E   | F |  G    
--------------|----------|---------|------|--------|---|-------
1 ANGLE       | 6        | 3-1/2   | 5-16 | 240    | 1 | C1054
2 SQAURE TUBE | 1-1/2    | 1-1/2   | 1/8  | 31-3/4 | 3 | C1588
3 DOM TUBE    | 5-1/2 OD | 1" WALL |      |        | 4 | C1670

Next I will take and move column A to be between columns D and E. Then I will somehow mash the numbers together using " X " and then mash that column with the next to reach the goal.

My code in vbscript is:

'inserting 3 blank columns into given format
objSheet2.Columns("C:C").Insert xlToRight
objSheet2.Columns("C:C").Insert xlToRight
objSheet2.Columns("C:C").Insert xlToRight
'splitting
Split objSheet2.Columns("B:B"),"x"
'objSheet2.Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
'        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
'        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
'        :="x", FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2)), _
'        TrailingMinusNumbers:=True
'moving column A between column E and F
objSheet2.Columns("A:A").Cut
objSheet2.Columns("F:F").Insert

I first recorded a macro and just pasted it into my vbscript all willy nilly and that obviously didn't work, that's why I have it commented out. The split command isn't working either. I'm getting a Type Mismatch error at the start of the Split line during the run. Note, in row 3 there is one less piece of information than the other lines have.

QUESTION: How do I arrive at my goal format from my given format using VBScript and possibly a split command?

Answer 1

I would approach a bit differently. Working with VBA arrays is usually faster than doing a lot of worksheet stuff

• Read the source data into a 2D vba array
• Using a Regular Expression, process the second column to remove the last item if and only if it matches the regex pattern below.
• Concatenate the "shortened" measurement with the description from Source column one, and put this into results column 1.
• Remove the 'x' and spaces from the captured last item of the measurement and put that into results column 2.
• Copy original columns three and four into the results array.
• Write the results array to a new worksheet, and do some formatting. (One could, by merely change the results worksheet, overwrite the original data).

This seems to work as you describe on your posted data:

Option Explicit
Sub ReFormat()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim I As Long
    Dim RE As Object, MC As Object

'set worksheets for source and results
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

'read source data into variant array
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 4).End(xlUp))
End With

'create results array
ReDim vRes(1 To UBound(vSrc, 1), 1 To UBound(vSrc, 2))

'Initialize Regex
Set RE = CreateObject("vbscript.regexp")
With RE
    .Global = True
    .ignorecase = True
    .Pattern = "\s+x\s+(\d[-./\d]*\d\b)\s*(?!.*x)"
End With

'Cycle through the rows
For I = 1 To UBound(vSrc, 1)
    vRes(I, 1) = Trim(RE.Replace(vSrc(I, 2), "")) & "  " & vSrc(I, 1)
    Set MC = RE.Execute(vSrc(I, 2))
        If MC.Count = 1 Then vRes(I, 2) = MC(0).submatches(0)
    vRes(I, 3) = vSrc(I, 3)
    vRes(I, 4) = vSrc(I, 4)
Next I

'write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .Columns(2).HorizontalAlignment = xlCenter
    .EntireColumn.AutoFit
End With

End Sub

And the Regex Pattern description:

\s+x\s+(\d[-./\d]*\d\b)\s*(?!.*x)

• Match a single character that is a “whitespace character” \s+
  • Between one and unlimited times, as many times as possible, giving back as needed (greedy) +
• Match the character “x” literally x
• Match a single character that is a “whitespace character” \s+
  • Between one and unlimited times, as many times as possible, giving back as needed (greedy) +
• Match the regex below and capture its match into backreference number 1 (\d[-./\d]*\d\b)
  • Match a single character that is a “digit” \d
  • Match a single character present in the list below [-./\d]*
    • Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
    • A single character from the list “-./” -./
    • A “digit” \d
  • Match a single character that is a “digit” \d
  • Assert position at a word boundary \b
• Match a single character that is a “whitespace character” \s*
  • Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
• Assert that it is impossible to match the regex below starting at this position (negative lookahead) (?!.*x)
  • Match any single character that is NOT a line break character .*
    • Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
  • Match the character “x” literally x

Created with RegexBuddy

Answer 2

Instead of splitting the whole column, you can just check how many " x " are in the cell value and update the cell values in column A and B accordingly

For Each cell In objSheet2.UsedRange.Resize(, 1)     ' column A
    a = Split( cell.Offset(0, 1).Value , " x ", 4 )  ' the cell in column B
    If UBound(a) > 2 Then                            ' if more than 2 " x "
        cell.Value = a(0) & " X " & a(1) & " X " & a(2) & " " & cell.Value
        cell.Offset(0, 1).Value = "'" & a(3)
    Else
        cell.Value = Replace( cell.Offset(0, 1).Value, " x ", " X " ) & " " & cell.Value
        cell.Offset(0, 1).Value = ""
    End If
Next