VBA Headers and Array

Hello Everyone,

I just joined this message board after having very little success in altering my VBA code. I have a data file and when I run the VBA code, it only works partly. Currently when I run the code, it will create new month headers, but only for a 12 month period and it is based off the current date on the computer. I need this to go to whatever specified date range I choose and I especially need it to go for more than 12 months. I am also having some issues because when my code runs, it is not running back far enough and there are gaps in the analysis that it does. For instance, after changing the time on my computer to 2009, project A and B's data stops in June 2009, even though the define phase is occuring before that. I have attached the code and I am looking for any help. Thank you very much and I hope someone can help me. Please let me know of any questions.

Hi

Had a quick look, and not really sure exactly what you are trying to achieve.

Can you add another sheet to the workbook, showing exactly what the output should be for the data provided, and explain where the controlling parameters come from in the source data.

rylo

Rylo,

Thanks for your response. I have created another tab that shows how I want the code to run. As you can see it runs for more than 12 months and doesn't have any gaps. Thanks for any help that you can give.

Rylo,

I understand your question. Ideally if a month had two things happening in it, it would have both. I didn't know if that would be possible, but if it is, that would be perfect. So cell G4 would be DM. Otherwise, I was just making a judgement call and was going with what occurred first or what was taking up more of the month. Also, I was essentially just being lazy by not putting the C to the last month.

Would it be possible to put in the range of dates that I want it to do the analysis for? Thank you.

Hi

Not sure why that is happening. Don't have any problems here, but I'm running on 2003, not 2007.

When it errors, go into debug mode, and check what is in each of the relevant variables. Also check and make sure that cdate, offset, dateadd etc are all valid items in 2007.

Let me know.

rylo

Rylo,

I tried the code again and it still doesn't seem to be working correctly. I went through the debugger and hit F1 on all of the terms where it says type mismatch and everything seems to be available in Excel 2007. This is what it says when I run the debugger and place the cursor over that line of code: "Placer,Offset(0,1).Value="Project Name"" I also tried putting the data in a new workbook and running it and it still had the same issues. The code does create the new worksheet, brings over the first 2 columns, and starts putting the dates at the top. Unfortunately, it keps creating the headers until no more columns can be added. It also does not create any of the inputs needed for each project (D,M,A,I,or C). I have posted what the outcome of the code looks like. Please let me know what I can do to help figure out what is going on.

Hi

Looks like it is an issue with the date format. I'm in Australia and have used a dmy construct, whereas I'd expect that you will be using a mdy structure.

One thing to modify will be

DateValue("1/12/" & Year(Date))

to perhaps

DateValue("12/1/" & Year(Date))

There may be other parts. Step through the code in debug mode and check what is going on whenever there is a date.

rylo

Rylo,

I made the change that you suggested. I am unsure how to or if I need to change the following lines:

MinDate = DateValue(Month(MinDate) & "1/" & "/" & Year(MinDate))
Placer.Offset(0, 1).Value = CDate(DateAdd("m", 1, Placer)
.Range(.Range("C1"), .Range("C1").End(xlToRight)).NumberFormat = "mmm yyyy"

I don't know if it's because I may not have changed everything correctly, but I am still getting the same error message, but now I am not getting any dates on the new sheet. I have attached what I have.

I apologize this is taking so much of your time, but I'd really like to get this to work. Thank you again.

Hi

Wouldn't it be more like

MinDate = DateValue(Month(MinDate) & "/1/" & Year(MinDate))

and

Do Until NewSH.Cells(1, Columns.Count).End(xlToLeft) = DateValue("12/1/" & Year(Date))

rylo

Rylo,

The sheet works almost perfectly now! Thank you. One more question, is it possible to have the data analysis stop once it has reached the forecasted control date? Thank you again!

Hi

To clarify, using your example file,
Project A would have a C from March to July inclusive
Project B - December 2009 only
Project C - March 2010 only
Project D - August 2009 only

Is that correct? You want the headings to go to the end of the year, but have the items filled from actual to forecast only where the forecast completion is later than the actual completion?

rylo

Rylo,
I would like to have the headers end with the actual control date. So if a project went into control in March, that would be the last date in the header.

Rylo,

Sorry for the confusion. Hopefully the attachment will alleviate it. Thank you.

Rylo,

Thanks for the info. The code is 99% there. The only issue now is that the date headers are not stopping where the data does. I have attached the file so that you can see. Thank you very much.

Also, if say something hasn't reached the control phase yet, the code doesn't seem to work correctly. Any suggestions?

Hi

Couple of things. From your example, I thought that all entries would be completed. If this example file doesn't fully represent your real data, then can you enhance to give a better picture of what it is likely to encounter.

1) To handle missing control dates, make the following couple of changes.

Set DataRNG = Range("C2:L" & Cells(Rows.Count, 1).End(xlUp).Row)

and

If ce.Column Mod 2 = 1 And Len(ce) > 0 Then

2) "headers end with actual control date" Do you want the headers to end with the maximum actual control date or forecast control date for all the projects rather than then end of the current calendar year? Or do you want to only have the data end at the greater of the 2 dates?

3) What do you want to happen when something doesn't get to control? Given that column L is a forecast date, I would have thought that this would have always been completed for the data.

rylo

Rylo,

Here are the answers to your questions.

1) I need the code to use the actual date for a phase assuming it exists, otherwise I need it to be based off of what the projected date is.
2) I actually need the control phase to go for a 3 month period on the chart that it creates and that should be where the date header ends. For example, if the project with the last control date is on 9/1/2010, the date headers would go to 11/1/2010 and a C would be where the analysis is for the final 3 months.
3) I misspoke about something not getting to control. If there is nothing in the actual date for any of the phases, I would like it to default to the projected date. There should be no instances where there is no projected date, so that should not be an issue.

I also noticed in the analysis that if say for instance the define phase started on 8/1/2009 and then the measure phase started on 8/15/2009, that there is a D and M in the analysis for that month. That is perfect. The issue that I am having is that for the months after that, there will continue to be DM in every month, even though there should only be an M because the define phase has ended when the measure phase started. Do you see any way to fix that?

I apologize for so many questions, but this is very close to being perfect and if it is possible to get these last few things changed, it will be. Thank you.

Hi

This is getting more and more confusing.

Can you please create an example file that shows all your possible scenarios, and a result sheet that shows how those scenarios would be handled. Explain on each item where the data has come from and why it was handled that way.

Have items where there is a forecast date, but no actual, 2 things happening on the same month etc.

rylo

Hi

OK, here goes again. Only difference between the output from this and your expected is for Q2. You have IC, but I think it should only be C.

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
  CodeARR = Array("", "", "", "D", "", "M", "", "A", "", "I", "", "C")
  
  Set DataSH = Sheets("June Macro Data")
  Set NewSH = Sheets.Add
  NewSH.Range("A:B").Value = DataSH.Range("A:B").Value
  DataSH.Activate
  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)
  MinDate = DateValue("1/" & Month(MinDate) & "/" & Year(MinDate))
  MaxDate = DateValue("1/" & Month(MaxDate) & "/" & Year(MaxDate))
  
'build the headings and format
  NewSH.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Value = MinDate
  Do Until NewSH.Cells(1, Columns.Count).End(xlToLeft) = DateValue("1/12/" & Year(Date))
    Set Placer = NewSH.Cells(1, Columns.Count).End(xlToLeft)
    Placer.Offset(0, 1).Value = CDate(DateAdd("m", 1, Placer))
  Loop
  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
    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
  
End Sub

rylo

Hi

I'm still not sure exactly where your header dates are supposed to end. I reverted back to the end of the current year as a fallback.

Using your last file, can you advise what is the last date that should be in the header? Should it be Feb2009, or March 2009???

rylo

Rylo,

The last month header should be where the last data is listed in the chart. In this case, that would be February 2009. Thank you.

Hi

OK, another go.

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
  CodeARR = Array("", "", "", "D", "", "M", "", "A", "", "I", "", "C")
  
  Set DataSH = Sheets("June Macro Data")
  Set NewSH = Sheets.Add
  NewSH.Range("A:B").Value = DataSH.Range("A:B").Value
  DataSH.Activate
  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)
  MinDate = DateValue("1/" & Month(MinDate) & "/" & Year(MinDate))
  MaxDate = DateValue("1/" & Month(MaxDate) & "/" & Year(MaxDate))
  MaxDate = DateAdd("M", 2, MaxDate)
'build the headings and format
  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
  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
    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
  
  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

rylo

Rylo,

This works perfectly! Thank you very much for helping me. I was wondering if you could be me one more favor. Would it be possible for you to put in additional comments about what some of the lines of code are doing? I understand about half of the code and the comments that you have included are helpful, but I would just like to learn exactly what is going on so that I may learn and help others as you helped me. Thank you a million times over.

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