时间轴 - 用给定间隔之间的缺失日期填写工作表

Question

我有以下 Excel 问题：

我目前在 sheet1 列 A、B、C 中有这个：

约会时间工作者
2016 年 4 月 4 日 4,5 约翰
2016 年 5 月 4 日 2 约翰
2016 年 6 月 4 日 6,5 约翰
2016 年 7 月 4 日 0 --
2016 年 8 月 4 日 0,5 查尔斯
2016 年 8 月 4 日 2 约翰
08/04/2016 0,5 威廉
09/04/2016 0 --
2016 年 10 月 4 日 0 --
2016 年 11 月 4 日 9 约翰
2016 年 11 月 4 日 3,75 威廉

我在表 3 中也有：
单元格 E1 中项目的创建日期：28/03/2016
单元格 F1 中项目的实际开始时间：2016 年 3 月 29 日
单元格 G1 中的今天日期（让我们考虑今天的日期是我接下来显示的日期）：13/04/2016

我想要在 sheet2 中的内容：

在项目创建和实际开始之间选择最早的日期，在本例中为 28/03/2016
然后使用 0 Time 和 -- Worker 添加缺少的日期，直到它到达 Today 日期。
完成后应该是这样的：

约会时间工作者
28/03/2016 0 --
2016 年 3 月 29 日 0 --
2016 年 3 月 30 日 0 --
2016 年 3 月 31 日 0 --
01/04/2016 0 --
2016 年 2 月 4 日 0 --
03/04/2016 0 --
2016 年 4 月 4 日 4,5 约翰
2016 年 5 月 4 日 2 约翰
2016 年 6 月 4 日 6,5 约翰
2016 年 7 月 4 日 0 --
2016 年 8 月 4 日 0,5 查尔斯
2016 年 8 月 4 日 2 约翰
08/04/2016 0,5 威廉
09/04/2016 0 --
2016 年 10 月 4 日 0 --
2016 年 11 月 4 日 9 约翰
2016 年 11 月 4 日 3,75 威廉
2016 年 12 月 4 日 0 --
2016 年 13 月 4 日 0 --

这是我遇到但现在才发现的问题的延续：
Timeline - loop through all dates between first and last given and add date to column if not found 寻找 excel-vba 宏解决方案，因为我相信这是唯一的方法。
我是 VBA 新手，遇到了这个问题，所有的帮助对我来说意义重大！

编辑说：创建日期、项目实际开始和今天并不重要的单元格可以在任何工作表中。只是为了举例而说的。希望提供的链接可以帮助你！

Answer 1

您可以使用@ScottCraner 提出的相同解决方案，只需更改几行

Sub timeline()

Dim i As Integer
Dim ws As Worksheet
Dim ts As Worksheet
Dim startDate as Date

Set ws = Sheets("Sheet15") 'Change to your Output Sheet
Set ts = Sheets("Sheet14") 'Change to your data sheet

' get the earliest day
startDate = cdate(application.WorksheetFunction.Min(cdate(ts.range("E1")),cdate(ts.range("E2"))))

With ws
    i = ts.Range("A" & ts.Rows.Count).End(xlUp).Row
    ts.Range("A1:C" & i).Copy .Range("A1")
    .Range("A1:C" & i).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
        key2:=.Range("C2"), Order2:=xlAscending, _
        Header:=xlYes
    Do Until .cells(i,1).value2 = startDate ' fill all dates 'til startDate
        If .Cells(i, 1).Value2 = .Cells(i - 1, 1).Value2 Or .Cells(i, 1).Value2 = .Cells(i - 1, 1).Value2 + 1 Then
            i = i - 1
        Else
            .Rows(i).Insert
            .Cells(i, 1).Value = .Cells(i + 1, 1).Value2 - 1
            .Cells(i, 2).Value = 0#
            .Cells(i, 3).Value = "--"
        End If
    Loop
End With

End Sub

Answer 2

这个答案对我有用。我用了一点@kellsens 代码，自己得到了答案！

Sub macro6()
Application.ScreenUpdating = False
Dim i As Long
Dim ws As Worksheet
Dim ts As Worksheet
Dim fs As Worksheet
Dim startDate As Date
Dim todaydate As Date

Folha13.Select

Set ws = Sheets("sheet1") 'Change to your Output Sheet
Set ts = Sheets("sheet2") 'Change to your data sheet
Set fs = Sheets("sheet3") 'Change to your data sheet
sheet2.Range("a1:c250").ClearContents

' get the earliest day
startDate = CDate(Application.WorksheetFunction.Min(CDate(fs.Range("b6")), CDate(fs.Range("b7"))))
todaydate = CDate(fs.Range("b10"))
With ws
    i = ts.Range("A" & ts.Rows.Count).End(xlUp).Row
    ts.Range("A1:C" & i).Copy .Range("A1")
    .Range("A1:C" & i).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
        key2:=.Range("C2"), Order2:=xlAscending, _
        Header:=xlYes

        i = 2
        If .Cells(i, 1).Value2 <> startDate Then
            .Rows(i).Insert
            .Cells(i, 1).Value = startDate
            .Cells(i, 2).Value = 0#
            .Cells(i, 3).Value = "--"

     End If

     i = ts.Range("A" & ts.Rows.Count).End(xlUp).Row + 1
           If .Cells(i, 1).Value2 <> todaydate Then
            .Rows(i + 1).Insert
            .Cells(i + 1, 1).Value = todaydate
            .Cells(i + 1, 2).Value = 0#
            .Cells(i + 1, 3).Value = "--"

     End If

      i = ts.Range("A" & ts.Rows.Count).End(xlUp).Row + 2

    Do Until .Cells(i, 1).Value2 = startDate ' fill all dates 'til startDate


          If .Cells(i, 1).Value2 = .Cells(i - 1, 1).Value2 Or .Cells(i, 1).Value2 = .Cells(i - 1, 1).Value2 + 1 Then
            i = i - 1
        Else
            .Rows(i).Insert
            .Cells(i, 1).Value = .Cells(i + 1, 1).Value2 - 1
            .Cells(i, 2).Value = 0#
            .Cells(i, 3).Value = "--"
        End If
  Loop

End With
Application.ScreenUpdating = True
End Sub