VBA to auto fill cells based on milestones and phases

[Kevw1]

Hi this is my first time posting and other then recording macros still very new to VBA but keen to learn, I have the following problem if anyone can help please? I have had a look in the forums and am struggling to utilise / find suitable code.

For summary only in table 1, this is my starting data, I have milestones that are against projects and months achieved for every milestone.

There are many more projects and months that span years in total, I need to convert the milestone to the Phase and populate the phase for the blank months until the next milestone is reached. In some cases milestones will be missing and may start half way through.

What I am trying to do is create a macro that:-
1. Check the value in the cell and matches to the milestone phase
2. If the cell is blank uses the previous milestone to calculate the phase
3. Repeat for every column against each project (many months over many years)
4. Repeat for each project
5. this can overwrite the data in the original sheet or creating a copy of the original sheet and update?
I will be changing the below "projects" and "Milestones" for actual data once I can understand the structure for this.

Table 2 show the results I am expecting, thanks again for any guidance where to start from.

Table 1
Project	Jun-17	Jul-17	Aug-17	Sep-17		Milestones	Phase
Project 1	M1			M3		M1	1
Project 2	M1	M2	M3	M4		M2	1
Project 3		M1		M2		M3	2
Project 4	M1			M5		M4	2
Project 5	M2			M3		M5	3
Project 6	M4			M5
Table 2
Project	Jun-17	Jul-17	Aug-17	Sep-17
Project 1	1	1	1	2
Project 2	1	1	2	2
Project 3		1	1	1
Project 4	1	1	1	3
Project 5	1	1	1	1
Project 6	2	2	2	3

<colgroup><col><col span="4"><col><col><col></colgroup><tbody>
</tbody>

​

 

[Kevw1]

when running the macro now it is blanking all but 2 of the milestones,

I am updating

Range("B2:E" & UsdRws)​

to B2:Z as this is the range currently in use and

For Each Cl In Range("G2", Range("G" & Rows.Count).End(xlUp))​

"G2" to "AB3" and "G" to "AB" as this is where the Milestone and Phase data is stored otherwise not changing anything.

 

[Fluff]

Is the Phase data in col AC?
Also if your milestones are not M1, M2 etc then you'll need to change the value in red below, to your first milestone

If Len(Rng) = 0 And Not Rng.End(xlToRight) = "[COLOR=#ff0000]M1[/COLOR]" Then

 

[Kevw1]

Hi yes the Phase data is in Col AC , Milestones in Col AB (headers are in row 2) with the first row of data in row 3, I have updated M1 to the first Milestone name (the name is "0-xxx" and each milestone starts with a number 0,01,02 etc then a text code if that could be an issue?), I have also tried moving the Phase table further away from the main data.

I have a test sheet I am running this in the workbook and copy and paste values from another sheet to reset the data before running the macro again, I have also copied the macro in to a new workbook and tried to run in that too, also tried the original code and that's not working now either it is only changing the existing milestones and not updating to the right the blank cells between milestones now.

The second code is blanking most of the data apart for 2-5 of the milestones, which keep changing each time i run the code.

 

[Fluff]

Are the blank cells actually blank, or do they have formulae returning "" ?

 

[Kevw1]

all blank I have double checked with =checkblank and =len and def all blank.

 

[Fluff]

I cannot replicate the problems you are encountering.
Would you be willing to upload your test book to OneDrive or dropbox, mark for sharing & post the link here?

 

[Kevw1]

Hi I have sent the link in a private message let me know if you get it OK?

 

[Fluff]

I have received the link thank you, but in order to conform to the rules, could you please also post the link to this thread?

 

[Kevw1]

yep sorry had not realised that, https://www.dropbox.com/s/4kl3pxomkjdq1rg/sample data.xlsm?dl=0

 

[Fluff]

The problem is that your blanks weren't blank.
When you copy/paste formulae, if the formula returns "" then a nullstring will be pasted. If you try =ISBLANK(U2) in AA2, it will return False.
Try this version

Sub Milestones()

    Dim UsdRws As Long
    Dim DataRng As Range
    Dim Cl As Range
    Dim Rng As Range
    
    UsdRws = Range("A" & Rows.Count).End(xlUp).Row
    Set DataRng = Range("B2:Z" & UsdRws)
    With DataRng
        .Value = .Value
    End With
    
    For Each Rng In Range("B2:B" & UsdRws)
        If Len(Rng) = 0 And Not Rng.End(xlToRight) = "01-bbb" Then
            If WorksheetFunction.CountA(DataRng.Rows(Rng.Row - 1)) > 0 Then
                Range(Rng, Rng.End(xlToRight)).FillLeft
            End If
        End If
    Next Rng

    For Each Cl In Range("AD3", Range("AD" & Rows.Count).End(xlUp))
        DataRng.Replace Cl.Value, Cl.Offset(, 1).Value, xlWhole, , False, , False, False
    Next Cl
    
    On Error Resume Next
    DataRng.Columns(1).SpecialCells(xlBlanks).Value = "X"
    On Error GoTo 0
    With DataRng.Offset(, 1).Resize(, DataRng.Columns.Count - 1)
        On Error Resume Next
        .SpecialCells(xlBlanks).FormulaR1C1 = "=rc[-1]"
        On Error GoTo 0
        .Value = .Value
    End With
    DataRng.Replace "X", "", xlWhole, , , , False, False
End Sub