Question

我有一个项目列表：

项目A
  项目B
  项目C

以及具有里程碑日期的每个项目的里程碑：

项目A里程碑1 01/01/2015
  项目A里程碑2 01/02/2015
  项目A里程碑3 01/03/2015
  B项目里程碑1 01/04/2015

我希望在一张表中为所有项目生成一种时间表，并在各自的月份显示里程碑。

列A将包含项目列表，第1行具有月份，然后显示月份和项目匹配的里程碑。

到目前为止，我已经能够使用宏提取项目列表：

Sub UniqueList()
Dim rListPaste As Range
Dim iReply As Integer

On Error Resume Next

Set rListPaste = Application.InputBox _
(Prompt:="Please select the destination cell", Type:=8)

    If rListPaste Is Nothing Then
       iReply = MsgBox("No range nominated," _
          & " terminate", vbYesNo + vbQuestion)
      If iReply = vbYes Then Exit Sub
    End If

   Range("A1", Range("A65536").End(xlUp)).AdvancedFilter _
   Action:=xlFilterCopy, CopyToRange:=rListPaste.Cells(1, 1), Unique:=True

End Sub

在此之后我很困惑。任何建议都将不胜感激。

Answer 1

我已经做了类似的设置，根据当周开发里程碑图表。我已修改它以符合您的要求：

Sub CreateMilestoneChart()

Dim ws1         As Worksheet
Dim ws2         As Worksheet
Dim LastRow     As Long
Dim i As Long, j As Long
Dim FirstMonth  As Long
Dim FirstYear   As Long
Dim LastMonth   As Long
Dim LastYear    As Long
Dim curRange    As Range

Set ws1 = Worksheets("Project List")
Set ws2 = Worksheets("Milestone Chart")

Application.ScreenUpdating = False

LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row

'-----You will want to modify or remove these lines once-----
'-----you get the sheet formatted the way you want-----------
ws2.Cells.Clear
ws2.Range("A1").Value = "Milestone Chart"
ws2.Range("A2").Value = "Generated on " & Date
ws2.Range("A3").Value = "Month:"
ws2.Range("A3").HorizontalAlignment = xlRight
'------------------------------------------------------------

ws1.Range("A1:C" & LastRow).Copy
ws2.Range("A4").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
    , SkipBlanks:=False, Transpose:=False

LastRow = LastRow + 3
For i = 4 To LastRow
    ws2.Cells(i, 1).Value = ws2.Cells(i, 1).Value & " " & ws2.Cells(i, 2).Value
Next i
ws2.Range("A4:A" & LastRow).HorizontalAlignment = xlRight
ws2.Range("B4:B" & LastRow).Delete Shift:=xlToLeft
With ws2.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B4:B" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A4:B" & LastRow)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

FirstMonth = DatePart("m", ws2.Range("B4").Value)
FirstYear = DatePart("yyyy", ws2.Range("B4").Value)
LastMonth = DatePart("m", ws2.Range("B" & LastRow).Value)
LastYear = DatePart("yyyy", ws2.Range("B" & LastRow).Value)

ws2.Range("B3").Value = CDate(FirstMonth & "/" & FirstYear)
Set curRange = ws2.Range("B3")
i = 1
Do Until DatePart("m", curRange.Value) = LastMonth And DatePart("yyyy", curRange.Value) = LastYear
    Set curRange = ws2.Cells(3, i + 2)
    curRange.Value = DateAdd("m", 1, ws2.Cells(3, i + 1).Value)
    i = i + 1
Loop
ws2.Cells(3, i + 2).Value = DateAdd("m", 1, ws2.Cells(3, i + 1).Value)

For i = 4 To LastRow
    j = 2
    Do Until ws2.Cells(i, j).Value >= ws2.Cells(3, j).Value And ws2.Cells(i, j).Value < ws2.Cells(3, j + 1).Value
        ws2.Cells(i, 2).Insert Shift:=xlToRight
        ws2.Cells(i, 2).Value = "'-----------------"
        j = j + 1
    Loop
Next i

Application.ScreenUpdating = True

End Sub

它不是很干净，但它会起作用。您需要对其进行修改以满足您的需求。

生成的项目组合时间表

1 个答案: