Attached the requested workbook. Sheet 1 contains the original information that the code provided formats. Sheet 2 shows the results of executing the code and shows what the format looks like. Sheet 3 shows the itemized list causing the issue. It is added into the original information.
The 1st workbook attached attempts to explain where the cells need to end up so that it all looks like sheet 2. This becomes complicated (at least in my mind) because it not only needs to reorder the cells, but draw from previous cells to fill in the missing pieces.
Here is the code provided to me, which works off of reassembling 13 cells of information per item. The additional code would need to address the issue of items that only contain 3 cells of information (because they are itemized under one number vs. one item per number) , but need the 10 other cells to draw from in order to reassemble like every other row of items.
I know it may sound a bit confusing, thus my cell by cell breakdown by colored backgrounds in the 1st workbook.
The code-
Option Explicit
Sub ReformatData()
Dim CaseFND As Range
Dim LR As Long, Rw As Long
Dim NR As Long
Application.ScreenUpdating = False
On Error Resume Next
Set CaseFND = Range("A:A").Find("Case:", LookIn:=xlValues, LookAt:=xlPart)
If CaseFND Is Nothing Then Exit Sub
Range("A1", CaseFND.Offset(-1)).Delete xlShiftUp
LR = Range("A" & Rows.Count).End(xlUp).Row
For Rw = LR To 1 Step -1
If Range("A" & Rw).Font.Bold = False Then
Range("A" & Rw + 1, "A" & LR).Delete xlShiftUp
Exit For
End If
Next Rw
LR = Range("A" & Rows.Count).End(xlUp).Row
NR = 1
For Rw = 2 To LR Step 12
Range("A" & Rw).Resize(12).Copy
Range("B" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Rw
Range("A2:A" & LR).ClearContents
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Bookmarks