Reputation: 1

Fill empty cells in a schedule

I'm helping my manager working on a personnel planning file and which has 3 dimensions: employee, week, and project name.

I want to fill in the blank cells between the project start date and End Date (see highlighted). I wrote the below code but it replaces the second project name with the first. (e.g. project 1 / project 2 for employee 1, project 3/project 6 for employee 2), and copy it until the end of the last project.

How can I proof-read my code and improve it to complete the purpose it is designed for?

Sub FillProjectDate_TEST1()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim startDate As Date, endDate As Date
    Dim project As String
    
    Set ws = ThisWorkbook.Sheets("Timeline") 
    
    ' Find the last row and last column with data

    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
    lastCol = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
    
    ' Loop through each row starting from row 4
    For i = 4 To lastRow
        ' Reset start and end dates for each row
        startDate = 0
        endDate = 0
        
        ' Loop through each column (week). First week is in column B.
        For j = 2 To lastCol
            ' Check if the cell has a project name
            If ws.Cells(i, j).Value <> "" Then
                ' If start date is not set, set it
                If startDate = 0 Then
                    startDate = ws.Cells(3, j).Value
                    project = ws.Cells(i, j).Value ' Store project name
                End If
                
                ' Always update end date to the current date
                endDate = ws.Cells(3, j).Value
            End If
        Next j
        
        ' Fill in cells between start and end dates with project name
        If startDate <> 0 And endDate <> 0 Then
            For j = 1 To lastCol
                If ws.Cells(3, j).Value >= startDate And ws.Cells(3, j).Value <= endDate Then
                    ws.Cells(i, j).Value = project
                End If
            Next j
        End If
    Next i
End Sub

[UPDATE]

Thanks again @taller for modifying the code.

One more question from my side. I want to modify the code to fill blanks to the end project date. In the case where thereas an overlapping period, how can i realistically replace with the second project name? From a starting data of this: Project Start/End Date It should be converted to something like this: Final Result

Upvotes: -1

Answers (2)

taller

Reputation: 18778

The code is based on my guess about your data layout

Option Explicit

Sub FillProjectDate_TEST1()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim startCol As Long, endCol As Long
    Dim project As String
    Set ws = ThisWorkbook.Sheets("Timeline")
'    Set ws = ActiveSheet ' for testing
    ' Find the last row and last column with data
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
    ' Loop through each row starting from row 4
    For i = 4 To lastRow
        ' Reset start and end dates for each row
        startCol = 0: endCol = 0
        ' Loop through each column (week). First week is in column B.
        For j = 2 To lastCol
            ' Check if the cell has a project name
            If ws.Cells(i, j).Value <> "" Then
                ' Always update end date to the current date
                endCol = j
                ' If start date is not set, set it
                If startCol = 0 Then
                    startCol = j
                    project = ws.Cells(i, j).Value ' Store project name
                Else
                    If startCol * endCol > 0 Then
                        ws.Cells(i, startCol).Resize(1, endCol - startCol).Value = project
                    End If
                    startCol = j
                    project = ws.Cells(i, j).Value
                End If
            End If
        Next j
        ' Fill in cells for the last project name in each row
        If startCol < lastCol Then
            ws.Cells(i, startCol).Resize(1, lastCol - startCol + 1).Value = project
        End If
    Next i
End Sub

Update

Option Explicit

Sub FillProjectDate_TEST1()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim startCol As Long, endCol As Long
    Dim project As String
'    Set ws = ThisWorkbook.Sheets("Timeline")
    Set ws = ActiveSheet ' for testing
    ' Find the last row and last column with data
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
    ' Loop through each row starting from row 4
    For i = 4 To lastRow
        ' Reset start and end dates for each row
        startCol = 0: endCol = 0
        ' Loop through each column (week). First week is in column B.
        For j = 2 To lastCol
            ' Check if the cell has a project name
            If ws.Cells(i, j).Value <> "" Then
                ' Always update end date to the current date
                endCol = j
                ' If start date is not set, set it
                If startCol = 0 Then
                    startCol = j
                    project = ws.Cells(i, j).Value ' Store project name
                Else
                    If startCol * endCol > 0 Then
                        ws.Cells(i, startCol).Resize(1, endCol - startCol).Value = project
                    End If
                    startCol = 0 ' **
'                    project = ws.Cells(i, j).Value ' **
                End If
            End If
        Next j
        ' Fill in cells for the last project name in each row
'        If startCol < lastCol And startCol > 0 Then
            'ws.Cells(i, startCol).Resize(1, lastCol - startCol + 1).Value = project
'        End If
    Next i
End Sub

Update2:

Question: if I have two projects that are overlapping, and one employee moves on to the second project

Note: The code can only handle two overlapping projects.

Option Explicit

Sub FillProjectDate_TEST3()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long, bOverLap As Boolean
    Dim startCol As Long, endCol As Long
    Dim Project As String, exProject As String
'    Set ws = ThisWorkbook.Sheets("Timeline")
    Set ws = ActiveSheet ' for testing
    ' Find the last row and last column with data
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
    ' Loop through each row starting from row 4
    For i = 4 To lastRow
        ' Reset start and end dates for each row
        startCol = 0: endCol = 0: bOverLap = False
        ' Loop through each column (week). First week is in column B.
        For j = 2 To lastCol
            ' Check if the cell has a Project name
            If ws.Cells(i, j).Value <> "" Then
                ' Always update end date to the current date
                endCol = j
                Project = ws.Cells(i, j).Value ' Store Project name
                ' If start date is not set, set it
                If startCol = 0 Then
                    startCol = j
                    exProject = ws.Cells(i, j).Value ' Store Project name
                Else
                    If startCol * endCol > 0 Then
                        If bOverLap And Project <> exProject Then
                            bOverLap = False
                        Else
                            ws.Cells(i, startCol).Resize(1, endCol - startCol).Value = exProject
                            If Project = exProject Then
                                startCol = 0
                                bOverLap = False
                            Else
                                startCol = endCol
                                exProject = Project
                                bOverLap = True
                            End If
                        End If
                    End If
                End If
            End If
        Next j
    Next i
End Sub

Upvotes: 0

Dominique

Reputation: 17501

Let me show you some real Excel power, based on the following Excel sheet:

I want to fill in the blanks, based on the value on the left. Therefore I select all cells I want to fill in, and then I only check the blank cells (CtrlG, "Special", "Blanks"):

This is what you get:

You see that cell "B1" is active, you want to fill in the value of "A1" (the one left to that cell) and you want to do this for all selected (blank) cells, so in the formula bar, you type =A1, but careful:
You don't ENTER but you type CtrlENTER, and this is what you get:

Did I mention Excel being powerful? :-)

Upvotes: 0

Fill empty cells in a schedule

Answers (2)

Related Questions