search cells for unique part and paste in new column -- difficult VB

[Kellens]

Hello, i am new to the boards and am struggeling with some macro i would to use.
I've looked for some examples but cannot find what i would need.

The current table is as follows:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Column header[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]recorded power 2200W[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]diameter 8 mm[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]lenght 15 mm[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]lenght 5 mm[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]lenght 10 mm[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]recorded power 5000W[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]recorded power 2500W[/TD]
[/TR]
</tbody>[/TABLE]

Now ideally i would like to have the following result

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]ID
[/TD]
[TD]Recorded power[/TD]
[TD]Diameter[/TD]
[TD]lenght[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]2200W[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD][/TD]
[TD]8 mm[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD][/TD]
[TD][/TD]
[TD]15 mm[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD][/TD]
[TD][/TD]
[TD]5 mm[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD][/TD]
[TD][/TD]
[TD]10 mm[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]5000W[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]2500W[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

So i was thinking that the part before a number would become the header and the number and everything behind it would become the value that is pasted in the corresponding column.

Would something like this would be possible?

 

[hiker95]

Kellens,

Have you even tried my macro solution?

If the raw data, and, results, that you posted in your original thread, reply #1, is not correct, can we have two more screenshots of some actual real data?

 

[Kellens]

Hello Hiker95,

Below you can find a screenshot of actual data.
I did try your code and it worked fine but as said in a previous post there are too many values to enter manually in the VBA code.
The code from Snakehips worked for me except for the blancs and cells withouth number which trows an error. Also there are a lot of blanc rows generated from his code.

Thanks for helping...

 

[Snakehips]

Perhaps try this.....

Sub Kellens()
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
lc = 3
For Each cell In Range("B2:B" & LR)


    If Not cell = "" Then
            For i = 1 To Len(cell)
                If Val(Mid$(cell, i)) > 0 Then
                    Ln = Mid$(cell, i)
                    Exit For
                End If
            Next i
        If i = 1 Then i = Len(cell)
        Head = StrConv(Trim(Left(cell, i)), vbProperCase)
        On Error Resume Next
        Hcol = WorksheetFunction.Match(Head, Rows(1), 0)
        On Error GoTo 0
            If Hcol = 0 Then
                Hcol = lc
                Cells(1, lc) = Head
                lc = lc + 1
            End If
                If i - 1 = Len(cell) Then
                    cell.Offset(0, Hcol - 2) = StrConv(Trim(cell), vbProperCase)
                    Else
                    cell.Offset(0, Hcol - 2) = Trim(Right(cell, Len(cell) - i))
                End If
        Hcol = 0
        
    End If
Next cell
End Sub

 

[Kellens]

WOW works like a charm
this is fantastic and will save me a LOT of work....

Thank you Snakehip and Hiker95 for putting in the effort

 

[Snakehips]

Wunderbar!!

We are happy to have helped.

 

[hiker95]

Kellens,

Thanks for the feedback.

You are very welcome. Glad Snakehips had a solution for you.

And, come back anytime.