Private Const FirstRow As Long = 3& Private Function GetOffset(ByVal forCategory As String) As Long Dim i As Long, Result As Long For i = 2& To Len(forCategory) Step 2& If Mid$(forCategory, i, 1&) <> " " Then Exit For Result = Result + 2& Next i GetOffset = Result End Function Public Sub ToSimpleTable() Dim i As Long, pos As Long Dim Category0 As String, Category2 As String Dim Category4 As String, Category6 As String Dim Category8 As String, LastCol As Long Dim pSource As Worksheet, pDest As Worksheet Dim sValue As String Set pSource = ActiveSheet Set pDest = Worksheets.Add pos = 1&: LastCol = pSource.UsedRange.Columns.Count Application.ScreenUpdating = False pSource.Select For i = FirstRow To pSource.UsedRange.Rows.Count sValue = Trim$(CStr(pSource.Cells(i, 1&).Value)) If (pSource.Cells(i, 1&).Font.Bold) And (sValue <> "") Then Select Case GetOffset(CStr(pSource.Cells(i, 1&).Value)) Case 0: Category0 = sValue Category2 = "": Category4 = "": Category6 = "": Category8 = "" Case 2: Category2 = sValue Category4 = "": Category6 = "": Category8 = "" Case 4: Category4 = sValue Category6 = "": Category8 = "" Case 6: Category6 = sValue Category8 = "" Case 8: Category8 = sValue End Select ElseIf sValue <> "" Then pos = pos + 1& pDest.Cells(pos, 1&).Value = Category0 pDest.Cells(pos, 2&).Value = Category2 pDest.Cells(pos, 3&).Value = Category4 pDest.Cells(pos, 4&).Value = Category6 pDest.Cells(pos, 5&).Value = Category8 pSource.Range(Cells(i, 1&), Cells(i, LastCol)).Copy pDest.Cells(pos, 6&) pDest.Cells(pos, 6&).Value = sValue End If Next i pDest.Select Application.ScreenUpdating = True End Sub |