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
Bookmarks