Hi

I've put in some more comments (new year's resolution - include more commentry). In some places I've tried to describe what the next block of code is doing in general terms.

If there are specific lines that you want explained, then don't be shy - ask away. I'm more than happy to explain what things are doing.

rylo

Sub aaa()
  Dim DataSH As Worksheet, NewSH As Worksheet
  Dim MaxDate As Date
  Dim MinDate As Date
  Dim Placer As Range, DataRNG As Range
  Dim ce, CodeARR, CurCode As String, i, j
  Dim OutRow As Long, OutCol As Integer, LastRow As Long
  'array of status codes to match the column numbers
  CodeARR = Array("", "", "", "D", "", "M", "", "A", "", "I", "", "C")
  
  Set DataSH = Sheets("June Macro Data")
  'add a new sheet, and bring in the data from columns A and B, and go back to the data sheet
  Set NewSH = Sheets.Add
  NewSH.Range("A:B").Value = DataSH.Range("A:B").Value
  DataSH.Activate
  
  'determine the data range
  Set DataRNG = Range("C2:L" & Cells(Rows.Count, 1).End(xlUp).Row)
  'determine min and max dates in data range to determine heading date range
  MinDate = WorksheetFunction.Min(DataRNG)
  MaxDate = WorksheetFunction.Max(DataRNG)
  'reformat the max and min dates to be first of month
  MinDate = DateValue("1/" & Month(MinDate) & "/" & Year(MinDate))
  MaxDate = DateValue("1/" & Month(MaxDate) & "/" & Year(MaxDate))
  'add 2 months to the maximun date
  MaxDate = DateAdd("M", 2, MaxDate)
'build the headings and format
'this loops until the date entered in the column matches the maximum date determined
'above in MaxDate.  It adds a month to the current cell and puts in the next one across
  NewSH.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Value = MinDate
  Do Until NewSH.Cells(1, Columns.Count).End(xlToLeft) = DateValue(MaxDate)
    Set Placer = NewSH.Cells(1, Columns.Count).End(xlToLeft)
    Placer.Offset(0, 1).Value = CDate(DateAdd("m", 1, Placer))
  Loop
  'formats the column headers
  With NewSH
    .Range(.Range("C1"), .Range("C1").End(xlToRight)).NumberFormat = "mmm yyyy"
  End With
    
    
  For Each ce In DataRNG
  'there is an actual start date.  Uses the ODD columns to determine if an actual date exists
    If ce.Column Mod 2 = 1 And Len(ce) > 0 Then
      OutCol = Evaluate("=match(" & ce.Address & "," & NewSH.Name & "!1:1)")
      OutRow = WorksheetFunction.Match(Cells(ce.Row, 1).Value, NewSH.Range("A:A"))
      NewSH.Cells(OutRow, OutCol).Value = NewSH.Cells(OutRow, OutCol).Value & CodeARR(ce.Column)
  'no start date so use forecast start date
    ElseIf ce.Column Mod 2 = 1 And Len(ce) = 0 Then
      OutCol = Evaluate("=match(" & ce.Offset(0, 1).Address & "," & NewSH.Name & "!1:1)")
      OutRow = WorksheetFunction.Match(Cells(ce.Row, 1).Value, NewSH.Range("A:A"))
      NewSH.Cells(OutRow, OutCol).Value = NewSH.Cells(OutRow, OutCol).Value & CodeARR(ce.Column)
    
    End If
  Next ce
  
  NewSH.Activate
  OutRow = Cells(Rows.Count, 1).End(xlUp).Row
  OutCol = Cells(1, Columns.Count).End(xlToLeft).Column
'fill in the missing codes until the end of the forecast date for that item
  For i = 2 To OutRow
    CurCode = ""
  'determine last column for item - assumes there will always be a
  'date for control.  If no actual, then there will be a forecast.

    'OutCol = Evaluate("=match('" & DataSH.Name & "'!L" & i & "," & NewSH.Name & "!1:1)")
    OutCol = Cells(i, Columns.Count).End(xlToLeft).Offset(0, 2).Column
    For j = 3 To OutCol
  'change the stored code when a new one is met
      If Len(Cells(i, j)) > 0 Then CurCode = Cells(i, j).Value
      Cells(i, j).Value = CurCode
  'process only the right code when there were 2 actions in the previous month
      If Len(Cells(i, j - 1)) > 1 Then
        Cells(i, j).Value = Right(Cells(i, j).Value, 1)
        CurCode = Cells(i, j).Value
      End If
    Next j
  Next i
  
'formatting
  Rows("1:1").Font.Bold = True
  With NewSH.Columns("C:N")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
  End With
    
  With Range(Cells(1, 3), Cells(1, 3).End(xlToRight))
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 90
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
  End With
  
  Range("A2").Select
  ActiveWindow.FreezePanes = True
  Columns.AutoFit
  
  LastRow = Cells(1, Columns.Count).End(xlToLeft).End(xlDown).Row
  'this is to get rid of any extra date header columns that may have been generated
  'it determines the last row used in that column.
  'If the row is the bottom of the sheet, then there is no data, so delete the column
  Do Until LastRow < Rows.Count
    Cells(1, Columns.Count).End(xlToLeft).EntireColumn.Delete
    LastRow = Cells(1, Columns.Count).End(xlToLeft).End(xlDown).Row
  
  Loop
  
End Sub