From cell to Cells extracting data

Hi all

I have excel report which has data in one cell but i like to break it down to different cells just below the data cell

for example the attached has data A1 and I manually extracted this under the headers in A3 to E3 , this is just one cell's data but more cells like A1 under Colum A


is there a macro will do this automatically? is this doable?

kind regards

Try

Sub test()
    Dim a, x, i As Long, t As Long, m As Object
    x = Split([a1], vbLf)
    ReDim a(1 To UBound(x) + 1, 1 To 5)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "\b(.+?)\u00A3 *([1-9]\d{0,2}(,\d{3})*\.\d{2})"
        For i = 0 To UBound(x)
            a(i + 1, 1) = Trim$(Split(x(i), "-")(0))
            x(i) = Split(x(i), "-")(1)
            For Each m In .Execute(x(i))
                t = IIf(m.submatches(0) Like "bill*", 2, 4)
                a(i + 1, t) = m.submatches(0)
                a(i + 1, t + 1) = m.submatches(1)
            Next
        Next
    End With
    [a4].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

Thank you very much this works but only for A1 data,

Is there a way we can carry on extracting A1,A2,A3,A4,.... so on, so on data, basically can any data, that Colum A has, be extracted either below cell or another sheet? As you can see new excel sheet that I attached that the data

carries down.


Many thanks for your help in advance.

Add a worksheet named "Sheet2".

Sub test()
    Dim a, b, e, s, i As Long, n As Long, t As Long, m As Object
    a = Sheets("sheet1").Cells(1).CurrentRegion.Resize(, 2).Value
    ReDim b(1 To UBound(a, 1) * 100, 1 To 5)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "\b(.+?)\u00A3 *([1-9]\d{0,2}(,\d{3})*\.\d{2})"
        For i = 1 To UBound(a, 1)
            For Each e In Split(a(i, 1), vbLf)
                If e <> "" Then
                    n = n + 1: b(n, 1) = Trim$(Split(e, "-")(0))
                    s = Split(e, "-")(1)
                    For Each m In .Execute(s)
                        t = IIf(m.submatches(0) Like "bill*", 2, 4)
                        b(n, t) = m.submatches(0)
                        b(n, t + 1) = m.submatches(1)
                    Next
                End If
            Next
        Next
    End With
    Sheets("sheet2").[a2].Resize(n, 5) = b
End Sub

That is amazing!! it is working.

It is my fault that I realised there is no gap between each cells extraction on Sheet2 , can this also be added to distinguish the each? If you cant not to worry I will work something out.

It is great job, I cant express my appreciation . Thank you again.

Add one line in bold.

                End If
            Next
            n = n + 1  '<--- this line
        Next
    End With

what can I say! I though this is never possible but you made it possible. I cant thank you enough. it is working perfectly. Respect!