Split the content of a cell into separate rows

[Bering]

Hello,

I have to review a reconciliation file similar to the one below. The problem is that in column 5 (Comment) there could be cells that include a number of items, which makes it impossible for me to filter/analyse the data, (i.e. comments for item #3 ).

Whenever a comment contains several items, each item is identified by a consecutive number followed by a dot.

For example, for item 3, the comment provides a break-down of the -51 difference as:

1. 5 missing instruction
2. 15 incorrect posting,
3. 31 timing difference

Item	Our quantity	Their quantity	Difference	Comment
1	20	30	-10	Timing difference
2	30	25	5	Under investigation
3	9	60	-51	1. 5 missing instruction 2. 15 incorrect posting, 3. 31 timing difference
4	10	10	-	No difference

<tbody>
</tbody>

Is there a way (vba, formulae, text to column..) to split the content of such cells into separate rows so that the result looks be something like this:

Item	Our quantity	Their quantity	Difference	Comment
1	20	30	-10	Timing difference
2	30	25	5	Under investigation
3	9	60	-51	1. 5 missing instruction
3	9	60	-51	2. 15 incorrect posting,
3	9	60	-51	3. 31 timing difference
4	10	10	-	No difference

<tbody>
</tbody>

Thanks for any suggestions.

 

[Peter_SSs]

Hi Peter... I was wondering if you could help me again. Not sure if I should open a new thread...

I would like amend the code

.Pattern = "\*[^\*]+"

to include the scenario where there is an Alt+Enter (CHAR(10)) between each numbered point

Thank you.

Not a new thread as this is just a continuation of the existing issue.

If you have Alt-Enter between points, but presumably not before the first point, and you still want to use RegExp then try this. Apart from a new Pattern line, I have compacted the code a little.

Sub Split_Rows_Reg_Exp_v2()
  Dim a As Variant, b As Variant, m As Variant
  Dim i As Long, j As Long, k As Long, uba2 As Long
  
  a = Range("A1", Range("E" & Rows.Count).End(xlUp)).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * 20, 1 To uba2)
  With CreateObject("VBScript.RegExp")
    .Global = True
    .Pattern = Chr(10) & "*[^" & Chr(10) & "]+"
    For i = 1 To UBound(a)
      For Each m In .Execute(a(i, uba2))
        k = k + 1
        For j = 1 To uba2 - 1
          b(k, j) = a(i, j)
        Next j
        b(k, uba2) = Trim(m)
      Next m
    Next i
  End With
  Range("A" & Rows.Count).End(xlUp).Offset(3).Resize(k, uba2).Value = b
End Sub

 

[Bering]

Works perfectly, thank you very much

 

[Peter_SSs]

Cheers.