Thread: Making a table with ID rows and Dates as columns

BrewingCoder,

Welcome to the Excel Forum.


Detach/open workbook ReorgData - BrewingCoder - EF782393 - SDG12.xls and run macro ReorgData.



If you want to use the macro on another workbook:


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' stanleydgromjr, 06/30/2011
' http://www.excelforum.com/excel-general/782393-making-a-table-with-id-rows-and-dates-as-columns.html
Dim ABC() As Variant
Dim LR As Long, a As Long, FC As Long
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
ABC = Range("A1:C" & LR).Value
Range("A2:C" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
  , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
  False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers, _
  DataOption2:=xlSortTextAsNumbers
Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(5), Unique:=True
Columns(2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(6), Unique:=True
LR = Cells(Rows.Count, 6).End(xlUp).Row
Range("F2:F" & LR).Sort Key1:=Range("F2"), Order1:=xlAscending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
Range("F2:F" & LR).Copy
Range("F1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range("F2:F" & LR).ClearContents
'c = Nothing
LR = Cells(Rows.Count, 5).End(xlUp).Row
For a = 2 To LR Step 1
  firstaddress = ""
  With Columns(1)
    Set c = .Find(Cells(a, 5), LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
      firstaddress = c.Address
      Do
        FC = 0
        On Error Resume Next
        FC = Application.Match(c.Offset(, 1), Rows(1), 0)
        On Error GoTo 0
        If FC > 0 Then
          Cells(a, FC) = c.Offset(, 2)
        End If
        Set c = .FindNext(c)
      Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
  End With
Next a
Range("A1").Resize(UBound(ABC), 3) = ABC
Range("D1").Select
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro,