change Array index formula to VBA

[Kevw1]

Hi I am currenlty using the following formula in excel, but due to the repetition it is causing significant performance issues. I was hoping that if I could add this in as a macro instead, this would improve the performance of the sheet and make the excel doc a bit more stable. I have done some VBA but not sure where to start converting this size formula.

The formula is currently in the tab "Monthly view" and copied in every cell in columns D-HW (Date's) and rows 2-561 (projects), the columns and rows will be updated with new values over time.

{=IFERROR(IF(INDEX('Project Plan'!$AF$3:INDEX('ProjectPlan'!$AF:$AF,COUNTA('Project Plan'!$AF:$AF)),MATCH($A2&D$1,'ProjectPlan'!$AE$3:INDEX('Project Plan'!$AE:$AE,COUNTA('ProjectPlan'!$AE:$AE))&'Project Plan'!$AH$3:INDEX('ProjectPlan'!$AH:$AH,COUNTA('Project Plan'!$AH:$AH)),0))="","",INDEX('ProjectPlan'!$AF$3:INDEX('Project Plan'!$AF:$AF,COUNTA('ProjectPlan'!$AF:$AF)),MATCH($A2&D$1,'Project Plan'!$AE$3:INDEX('ProjectPlan'!$AE:$AE,COUNTA('Project Plan'!$AE:$AE))&'ProjectPlan'!$AH$3:INDEX('Project Plan'!$AH:$AH,COUNTA('Project Plan'!$AH:$AH)),0))),"")}

Any help on how to improve this formula would be great, Thanks

 

[Norie]

What does the formula do?

 

[Kevw1]

Hi so the Formula converts the following data

Project Ref	Phase	EOMonth
P1	Start	01/01/10
P1	0 - Phase1	01/02/10
P1	01 - Phase2	01/05/19
P1	02 - Phase3	01/11/19
P1	03 - Phase4	01/11/19
P1	04 - Phase5	01/05/20
P1	05 - Phase6	01/12/20
P1	06 - Phase7	01/12/20
P1	07 - Phase8	01/06/21
P1	08 - Phase9	01/10/22
P1	09 - Phase10	01/04/23
P1	10 - Phase11	01/10/23

<tbody>
</tbody>

To the following table

<strike></strike>

Project ID	Jan-10	Feb-10	Mar-10
P1	Start	0 – Phase1

<tbody>
</tbody>

This is repeated for each of the Projects and for all dates listed in the columns D1-HW1, where there is no value then it needs to be Blank please. Hope this helps?

 

[Norie]

Which column(s) is the data in on the sheet 'Project Plan'?

 

[Kevw1]

Hi Project Plan columns are:-

Project Ref = Column AE
Phase = Column AF
EOMonth = Column AH

<tbody style="border-collapse: collapse; border-spacing: 0px 0px; font-size: 13px; margin-bottom: 0px;">
</tbody>

 

[Norie]

Not 100% sure what you are looking for but the folowing code should 'create' the monthly view from the data on 'Project Plan'.

Note, this doesn't not create formulas on the sheet 'Monthly View so would need to be run whenever a (significant?) change was made on the 'Project Plan'

Option Explicit

Sub CreateMonthlyView()
Dim rngDst As Range
Dim arrIn As Variant
Dim arrOut As Variant
Dim dicProjects As Object
Dim I As Long
Dim mth As Long
Dim ky As Variant

    With Sheets("Project Plan")
        arrIn = .Range("AE3", .Range("AH" & Rows.Count).End(xlUp)).Value
    End With
    
    Set dicProjects = CreateObject("Scripting.Dictionary")
    
    For I = 1 To UBound(arrIn)
        If Not dicProjects.exists(arrIn(I, 1)) Then
            ReDim arrOut(1 To 228)
            mth = DateDiff("m", DateSerial(2010, 1, 1), arrIn(I, 4)) + 1
            arrOut(mth) = arrIn(I, 2)
            dicProjects.Add arrIn(I, 1), arrOut
            
        Else
            arrOut = dicProjects(arrIn(I, 1))
            
            mth = DateDiff("m", DateSerial(2010, 1, 1), arrIn(I, 4)) + 1
            
            arrOut(mth) = arrIn(I, 2)
            dicProjects(arrIn(I, 1)) = arrOut
            
        End If
        
    Next I
    
    Set rngDst = Sheets("Monthly View").Range("D2")
    
    For Each ky In dicProjects.keys
        rngDst.Offset(, -3).Value = ky
        rngDst.Resize(, 228).Value = dicProjects(ky)
        Set rngDst = rngDst.Offset(1)
    Next ky
    
End Sub

 

[Kevw1]

Hi thanks for this, but for some reason it is throughing an error Subscript out of range at

arrOut(mth) = arrIn(I, 2)
​

 

[Norie]

Does this work without error?

Option Explicit

Sub CreateMonthlyView()
Dim rngDst As Range
Dim arrIn As Variant
Dim arrOut As Variant
Dim dicProjects As Object
Dim I As Long
Dim mth As Long
Dim ky As Variant

    With Sheets("Project Plan")
        arrIn = .Range("AE3", .Range("AH" & Rows.Count).End(xlUp)).Value
    End With
    
    Set dicProjects = CreateObject("Scripting.Dictionary")
    
    For I = 1 To UBound(arrIn)
        If Not dicProjects.exists(arrIn(I, 1)) Then
            ReDim arrOut(1 To 228)
            mth = DateDiff("m", DateSerial(2010, 1, 1), arrIn(I, 4)) + 1

            If mth>1 And mth<229 then
                arrOut(mth) = arrIn(I, 2)
            End If

            dicProjects.Add arrIn(I, 1), arrOut
            
        Else
            arrOut = dicProjects(arrIn(I, 1))
            
            mth = DateDiff("m", DateSerial(2010, 1, 1), arrIn(I, 4)) + 1
            
            If mth>1 And mth<229 then
                arrOut(mth) = arrIn(I, 2)
            End If

            dicProjects(arrIn(I, 1)) = arrOut
            
        End If
        
    Next I
    
    Set rngDst = Sheets("Monthly View").Range("D2")
    
    For Each ky In dicProjects.keys
        rngDst.Offset(, -3).Value = ky
        rngDst.Resize(, 228).Value = dicProjects(ky)
        Set rngDst = rngDst.Offset(1)
    Next ky
    
End Sub

 

[Kevw1]

Hi Thanks all working as expected, just takes about 3-4 mins to fully run, but does what it needs to thanks for your help.