using vba to clean up data

[padadof2]

I have to clean up data and I'm hoping some excel Guru's can help me out. I get data has everything in one cell, separated by spaces, and I'd like to get it into a proper formatting, having one word per cell, but there's a caveat. Every even row, I need all that text in one cell

Here is the data I get in a single cell:

0696-0600 J1 Each 2.0000 N
TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2
0697-0600 J1 Each 2.0000 N
RESET TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2
0802-0001 C1, M Cubic Yard 99.0000 N
TOPSOIL FURNISHED AND PLACED
0867-0012 M2 Linear Foot 170.0000 N
COMPOST FILTER SOCK, 12" DIAMETER
0901-0001 Q Lump Sum 1.0000 N
MAINTENANCE AND PROTECTION OF TRAFFIC DURING CONSTRUCTION
0855-0003 M2 Each 1.0000 N
PUMPED WATER FILTER BAG
0855-0004 M2 Each 1.0000 N
REPLACEMENT PUMPED WATER FILTER BAG

Here is what I would like the vba to do:

0696-0600	TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2	2	Each
0697-0600	RESET TEMPORARY IMPACT ATTENUATING DEVICE, TYPE V (STANDARD), TEST LEVEL 2	2	Each
0802-0001	TOPSOIL FURNISHED AND PLACED	99	Cubic Yard
0867-0012	COMPOST FILTER SOCK, 12" DIAMETER	170	Linear Foot
0901-0001	MAINTENANCE AND PROTECTION OF TRAFFIC DURING CONSTRUCTION	1	Lump Sum
0855-0003	PUMPED WATER FILTER BAG	1	Each
0855-0004	REPLACEMENT PUMPED WATER FILTER BAG	1	Each

This is what I've come up with so far:

Sub pdtest()
Dim MyArray() As String, MyString As String, I As Variant, N As Integer, r As Integer, lr As Integer

    lr = Cells(Rows.Count, 1).End(xlUp).Row
    I = 2
        For r = 1 To lr Step 2
            Cells(r, 1).Select
            MyString = ActiveCell.Value

            MyArray = Split(MyString, " ")

            For N = 0 To UBound(MyArray)
                Cells(lr + 1, N + 1).Value = MyArray(N)
            Next N
            
            Cells(lr + 1, 2).Value = Cells(I, 1).Value
            I = I + 2
    lr = lr + 1
Next r
End Sub

Hopefully some guru's are willing to help

 

[Fluff]

That is now so messed up it's almost impossible to sort out, there are too many possible permutations.

 

[padadof2]

That is now so messed up it's almost impossible to sort out, there are too many possible permutations.

I was afraid of that. Thanks for looking at it again, and thanks for the initial solution. I'll manually clean the extras up, as it's better than doing it all manually!

 

[Fluff]

You're welcome.

 

[Fluff]

As long as the number for col E is always followed by " N " try

Sub padadof()
   Dim NxtRw As Long, i As Long
   Dim Tmp As Variant, Sp As Variant
   Dim Cl As Range
   
   With Sheets("lists")
      .Range("C:F").ClearContents
      For Each Cl In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
         If Cl.Row Mod 2 = 1 Then
            NxtRw = NxtRw + 1
            Sp = Split(Trim(Cl.Value))
            .Range("C" & NxtRw).Value = Sp(0)
            For i = UBound(Sp) To 0 Step -1
               If Sp(i) = "N" Then Exit For
            Next i
            Tmp = Split(StrReverse(Trim(Cl.Value)), , UBound(Sp) - i + 3)
            .Range("E" & NxtRw) = StrReverse(Tmp(UBound(Sp) - i + 1))
            Tmp = StrReverse(Tmp(UBound(Sp) - i + 2))
            If Len(Split(Tmp)(2)) > 2 Then
               .Range("F" & NxtRw) = Split(Tmp, , 3)(2)
            Else
               .Range("F" & NxtRw) = Split(Tmp, , 4)(3)
            End If
         Else
            .Range("D" & NxtRw) = Cl.Value
         End If
      Next Cl
   End With
End Sub

 

[padadof2]

As long as the number for col E is always followed by " N " try

Sub padadof()
   Dim NxtRw As Long, i As Long
   Dim Tmp As Variant, Sp As Variant
   Dim Cl As Range
  
   With Sheets("lists")
      .Range("C:F").ClearContents
      For Each Cl In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
         If Cl.Row Mod 2 = 1 Then
            NxtRw = NxtRw + 1
            Sp = Split(Trim(Cl.Value))
            .Range("C" & NxtRw).Value = Sp(0)
            For i = UBound(Sp) To 0 Step -1
               If Sp(i) = "N" Then Exit For
            Next i
            Tmp = Split(StrReverse(Trim(Cl.Value)), , UBound(Sp) - i + 3)
            .Range("E" & NxtRw) = StrReverse(Tmp(UBound(Sp) - i + 1))
            Tmp = StrReverse(Tmp(UBound(Sp) - i + 2))
            If Len(Split(Tmp)(2)) > 2 Then
               .Range("F" & NxtRw) = Split(Tmp, , 3)(2)
            Else
               .Range("F" & NxtRw) = Split(Tmp, , 4)(3)
            End If
         Else
            .Range("D" & NxtRw) = Cl.Value
         End If
      Next Cl
   End With
End Sub

You Are Amazing!!! Thank you so much!

 

[Fluff]

My pleasure.