Question

我一直试图这样做一段时间，但我觉得我的VBA技能还没有达到或者我错过了一些非常明显的东西。我花了几个小时试图自己解决这个问题并且没有找到任何有效的方法。它过于复杂，我无法正确编码VBA。

我试图做的是VLOOKUP日期和使用它作为起点，然后使用一个函数来填充标签单元格内容的所有日子（缺少周末和其他银行假日），以便显示在时间表。

但我无法解决如何做到这一点：

我希望能够更改开始日期和结束日期并让日历自动填充，因为这个日历是一年半，我不想手动完成。

感谢任何人愿意提供的任何帮助。

对，谢谢你Tony的精彩回答，虽然它仍然让我遇到了问题，但我能够适应并创建这个代码来解决我的问题。

Sub fillCalendar()

Dim StartDate As Long
Dim finishDate As Long
Dim daystotal As Long
Dim counter As Integer
counter = 0

'start date is 02/01/2016 / 42371

StartDate = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
finishDate = ActiveCell.Value
daystotal = finishDate - StartDate
ActiveCell.Offset(0, 2).Activate
Selection.Copy

ActiveCell.Offset(0, StartDate - 42371).Select

While counter <= daystotal
If Worksheets("Schedule").Cells(3, ActiveCell.Column) <> "S" Then

    counter = counter + 1
    Worksheets("Schedule").Paste
    ActiveCell.Offset(0, 1).Activate
Else
    counter = counter + 1
    ActiveCell.Offset(0, 1).Activate
End If
Wend



End Sub

这个非常简单的代码将检查每一列，看它是否是工作日。如果是这样，它将粘贴TAG单元格的内容并移动，向计数器添加一个。当计数器满足totaldays计数时，while循环退出，留下填充的日历。感谢大家的帮助

Answer 1

这不是您问题的直接答案。但是，它提供了一个宏，我相信你会觉得它很有用，它展示了你所寻求的宏所需的技术。

在我对你的问题做任何事情之前，我需要一些测试数据。我手动创建了这个工作表：

我已经减少了A到F列的大小，所以我可以在屏幕上获得更多，而不会太小。我的颜色和格式可能与你的不一样，但正如我稍后会解释的那样，这并不重要。

唯一重要的不同是本月的标题，我已从“1月”更改为“2016年1月”。我假设“January”是一个字符串。在我的工作表上，这是日期“2016年1月1日”格式化为显示为“2016年1月”。我可以把它格式化为“1月”，但我想让这个变化显而易见，因为我的宏取决于它。

让这个1月份格式化得足以让人费心。我不想在二月和三月做同样的事情。我假设你发现额外的一个月的标题是一件苦差事。所以我写了一个宏来在任何现有月份的右边添加一个新月。

运行宏一次，你得到：

再次运行它，你得到：

让我的宏工作花了足够长的时间，所以我没有想过你寻求的宏。但是，我确信我的宏演示了您需要的所有技术。

我只使用一个范围，因为我的宏主要用于单个单元格。但是，它显示了如何创建范围，合并其中的单元格以及格式化合并的单元格。

我说我的格式与你的格式略有不同并不重要。我的宏通过复制上个月的格式来格式化新月份。如果我包含Application.ScreenUpdating = False，宏会更快，但这是一个演示宏。完成学习后，删除诊断语句并添加Application.ScreenUpdating = False。

我使用DateSerial和DateDiff等函数来计算我需要的值。当我学习VBA时，我打开了VBA帮助并编写了语句，方法和函数列表。如果某些内容对我有用，我会仔细阅读文字。如果它看起来不实用，我会读到足够的知道，以防万一我的需求发生变化。例如，有许多异国情调的财务功能对我来说毫无价值，但我知道如果我的需求发生变化，那里就会有。有一个函数可以计算两个日期之间的工作日数，这可能对您有用。

解决我的问题。我没有解释单个VBA语句，因为一旦你知道它们存在就很容易查找。但是，我解释了每个代码块的目标。对于宏，您需要将Tag单元格中的值和颜色复制到右侧的相应单元格。我的宏计算特定日期和上个月最后一个星期日的列号。我的宏将值和格式从一个单元格复制到另一个单元格。这些是您需要的技术。尽可能回答问题，但我相信仔细研究我的宏将为您提供所需的所有信息。

Option Explicit

  ' Constants are a convenient way of defining important values:
  '  * If the value changes, one amendment here and the macro(s) that use the
  '    value are immediately updated.
  '  * It makes the code easier to read because "magic numbers" are replaced by
  '    meaningful names.
  Const ColDateStart As Long = 5        ' 5 = Column E
  Const ColDateEnd As Long = 6          ' 6 = Column F
  Const ColDateTag As Long = 8          ' 8 = Column H
  Const ColFirstDay As Long = 9         ' 9 = Column I
  Const RowMonth As Long = 1            ' Row for month names
  Const RowDow As Long = 2              ' Row for days of week as initial letters
  Const RowDom As Long = 3              ' Row for days of month as numbers
  Const RowDataFirst As Long = 4
  Const WshtName As String = "Calendar" ' Amend for your name for the worksheet
Sub AddExtraMonth()

  Dim BorderDayLeftColor As Long
  Dim BorderDayLeftLineStyle As Long
  Dim BorderDayLeftWeight As Long
  Dim BorderMonthRightColor As Long
  Dim BorderMonthRightLineStyle As Long
  Dim BorderMonthRightWeight As Long
  Dim ColCrnt As Long
  Dim ColEndNewMonth As Long
  Dim ColStartNewMonth As Long
  Dim ColLastRowMonth As Long
  Dim ColOffset As Long
  Dim ColSunday As Long
  Dim ColSource As Long
  Dim Dom As Long
  Dim DowMonthNewStart As Long
  Dim FontColor As Long
  Dim InteriorColor As Long
  Dim MonthCrntLast As Date
  Dim MonthNewEnd As Date
  Dim MonthNewStart As Date
  Dim NumDaysNewMonth As Long
  Dim NumberFormat As String
  Dim Pattern As Long
  Dim PatternColorIndex As Long
  Dim RngRowMonththNew As Range
  Dim RowCrnt As Long
  Dim RowLast As Long

  With Sheets(WshtName)

    ' Get useful column and row numbers
    ColLastRowMonth = .Cells(RowMonth, Columns.Count).End(xlToLeft).Column
    ColStartNewMonth = .Cells(RowDow, Columns.Count).End(xlToLeft).Column + 1
    RowLast = .Cells(Rows.Count, ColDateStart).End(xlUp).Row

    Debug.Print "ColLastRowMonth " & ColLastRowMonth
    Debug.Print "ColStartNewMonth " & ColStartNewMonth
    Debug.Print "RowLast " & RowLast

    ' Get last current month. Calculate first and last day of new month
    MonthCrntLast = .Cells(RowMonth, ColLastRowMonth)  ' Last value in row RowMonth is current last month
    MonthNewStart = DateSerial(Year(MonthCrntLast), Month(MonthCrntLast) + 1, 1)
    MonthNewEnd = DateSerial(Year(MonthNewStart), Month(MonthNewStart) + 1, 0)

    Debug.Print "MonthCrntLast " & Format(MonthCrntLast, "ddd d mmm yy")
    Debug.Print "MonthNewStart " & Format(MonthNewStart, "ddd d mmm yy")
    Debug.Print "MonthNewEnd " & Format(MonthNewEnd, "ddd d mmm yy")

    ' Calculate column of last sunday of current last month
    DowMonthNewStart = Weekday(MonthNewStart)
    ColSunday = ColStartNewMonth - DowMonthNewStart + 1

    Debug.Print "DowMonthNewStart " & DowMonthNewStart
    Debug.Print "ColSunday " & ColSunday & " = " & ColNumToCode(ColSunday)

    ' Calculate number of days in new month.
    ' Calcutate last column of new month
    NumDaysNewMonth = DateDiff("d", MonthNewStart, MonthNewEnd) + 1
    ColEndNewMonth = ColStartNewMonth + NumDaysNewMonth - 1

    Debug.Print "NumDaysNewMonth " & NumDaysNewMonth
    Debug.Print "ColStartNewMonth " & ColStartNewMonth & " = " & ColNumToCode(ColStartNewMonth)
    Debug.Print "ColEndNewMonth " & ColEndNewMonth & " = " & ColNumToCode(ColEndNewMonth)

    ' Calulate range for new month within row RowMonth
    Set RngRowMonththNew = .Range(.Cells(RowMonth, ColStartNewMonth), .Cells(RowMonth, ColEndNewMonth))

    Debug.Print "RngRowMonththNew " & Replace(RngRowMonththNew.Address, "$", "")

    ' Size new columns to match columns from previous month
    RngRowMonththNew.Columns.ColumnWidth = .Cells(RowMonth, ColStartNewMonth - 2).ColumnWidth

    ' Get formats from previous month
    With .Cells(RowMonth, ColLastRowMonth)
      FontColor = .Font.Color
      InteriorColor = .Interior.Color
      NumberFormat = .NumberFormat
    End With

    With .Cells(RowDow, ColStartNewMonth - 1)
      ' Note these value are not used until the end
      BorderMonthRightLineStyle = .Borders(xlEdgeRight).LineStyle
      BorderMonthRightWeight = .Borders(xlEdgeRight).Weight
      BorderMonthRightColor = .Borders(xlEdgeRight).Color
    End With

    ' Merge and format cells to contain month name
    RngRowMonththNew.Merge
    With .Cells(RowMonth, ColStartNewMonth)
      .Value = MonthNewStart
      .NumberFormat = NumberFormat
      .HorizontalAlignment = xlCenter
      .Font.Color = FontColor
      .Interior.Color = InteriorColor
    End With

    With .Cells(RowMonth, ColEndNewMonth)
      With .Borders(xlEdgeRight)
        .LineStyle = BorderMonthRightLineStyle
        .Weight = BorderMonthRightWeight
        .Color = BorderMonthRightColor
      End With
    End With

    ' Copy value and formats for new month within RowDow from cells in middle of previous month
    ColSource = ColStartNewMonth - 14
    ColOffset = 0
    For ColCrnt = ColStartNewMonth To ColEndNewMonth
      .Cells(RowDow, ColCrnt).Value = .Cells(RowDow, ColSource + ColOffset).Value
      .Cells(RowDow, ColCrnt).HorizontalAlignment = .Cells(RowDow, ColSource + ColOffset).HorizontalAlignment
      .Cells(RowDow, ColCrnt).Font.Color = .Cells(RowDow, ColSource + ColOffset).Font.Color
      .Cells(RowDow, ColCrnt).Interior.Color = .Cells(RowDow, ColSource + ColOffset).Interior.Color
      If ColCrnt > ColStartNewMonth Then
        ' Only set left border if not firsst day of month so month border untouched
        .Cells(RowDow, ColCrnt).Borders(xlEdgeLeft).LineStyle = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeLeft).LineStyle
        .Cells(RowDow, ColCrnt).Borders(xlEdgeLeft).Weight = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeLeft).Weight
        .Cells(RowDow, ColCrnt).Borders(xlEdgeLeft).Color = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeLeft).Color
      End If
      .Cells(RowDow, ColCrnt).Borders(xlEdgeBottom).LineStyle = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeBottom).LineStyle
      .Cells(RowDow, ColCrnt).Borders(xlEdgeBottom).Weight = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeBottom).Weight
      .Cells(RowDow, ColCrnt).Borders(xlEdgeBottom).Color = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeBottom).Color
      ColOffset = ColOffset + 1
      If ColOffset = 7 Then
        ColOffset = 0
      End If
    Next

    ' Set right border for month for row RowDow
    With .Cells(RowDow, ColEndNewMonth).Borders(xlEdgeRight)
      .LineStyle = BorderMonthRightLineStyle
      .Weight = BorderMonthRightWeight
      .Color = .Color
    End With

    ' Copy formats for new month within RowDom from cells in middle of previous month
    ' Set days of month
    ColSource = ColStartNewMonth - 14
    ColOffset = 0
    Dom = 1
    For ColCrnt = ColStartNewMonth To ColEndNewMonth
      .Cells(RowDom, ColCrnt).Value = Dom
      .Cells(RowDom, ColCrnt).HorizontalAlignment = .Cells(RowDom, ColSource + ColOffset).HorizontalAlignment
      .Cells(RowDom, ColCrnt).Font.Color = .Cells(RowDom, ColSource + ColOffset).Font.Color
      .Cells(RowDom, ColCrnt).Interior.Color = .Cells(RowDom, ColSource + ColOffset).Interior.Color
      If ColCrnt > ColStartNewMonth Then
        ' Only set left border if not firsst day of month so month border untouched
        .Cells(RowDom, ColCrnt).Borders(xlEdgeLeft).LineStyle = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeLeft).LineStyle
        .Cells(RowDom, ColCrnt).Borders(xlEdgeLeft).Weight = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeLeft).Weight
        .Cells(RowDom, ColCrnt).Borders(xlEdgeLeft).Color = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeLeft).Color
      End If
      .Cells(RowDom, ColCrnt).Borders(xlEdgeBottom).LineStyle = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeBottom).LineStyle
      .Cells(RowDom, ColCrnt).Borders(xlEdgeBottom).Weight = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeBottom).Weight
      .Cells(RowDom, ColCrnt).Borders(xlEdgeBottom).Color = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeBottom).Color
      ColOffset = ColOffset + 1
      If ColOffset = 7 Then
        ColOffset = 0
      End If
      Dom = Dom + 1
    Next

    ' Set right border for month for row RowDom
    With .Cells(RowDom, ColEndNewMonth).Borders(xlEdgeRight)
      .LineStyle = BorderMonthRightLineStyle
      .Weight = BorderMonthRightWeight
      .Color = .Color
    End With

    ' Get pattern for last Sunday.  Assume same pattern used for Saturdays
    With .Cells(RowDataFirst, ColSunday)
      InteriorColor = .Interior.Color
      Pattern = .Interior.Pattern
      PatternColorIndex = .Interior.PatternColorIndex
      ' Get borders for last Sunday. Assume left border used for all borders
      With .Borders(xlEdgeLeft)
        BorderDayLeftLineStyle = .LineStyle
        BorderDayLeftWeight = .Weight
        BorderDayLeftColor = .Color
      End With
    End With

    ColCrnt = ColSunday + 6         ' Column for first Saturday of new month
    Do While True
      ' Set pattern for Saturday and Sunday for every data row
      For RowCrnt = RowDataFirst To RowLast
        .Cells(RowCrnt, ColCrnt).Interior.Pattern = Pattern
        .Cells(RowCrnt, ColCrnt).Interior.PatternColorIndex = PatternColorIndex
        .Cells(RowCrnt, ColCrnt).Interior.Color = InteriorColor
      Next
      ColCrnt = ColCrnt + 1     ' Advance to Sunday
      If ColCrnt > ColEndNewMonth Then
        ' All Saturdays and Sundays of new month marked
        Exit Do
      End If
      For RowCrnt = RowDataFirst To RowLast
        .Cells(RowCrnt, ColCrnt).Interior.Pattern = Pattern
        .Cells(RowCrnt, ColCrnt).Interior.PatternColorIndex = PatternColorIndex
        .Cells(RowCrnt, ColCrnt).Interior.Color = InteriorColor
      Next
      ColCrnt = ColCrnt + 6     ' Advance to next Saturday
      If ColCrnt > ColEndNewMonth Then
        ' All Saturdays and Sundays of new month marked
        Exit Do
      End If
    Loop

    ' Set borders of data cells for new month
    For RowCrnt = RowDataFirst To RowLast
      For ColCrnt = ColStartNewMonth To ColEndNewMonth
        If ColCrnt > ColStartNewMonth Then
          ' Only set border if not first day of month so left border for month untouched
          With .Cells(RowCrnt, ColCrnt)
            With .Borders(xlEdgeLeft)
              .LineStyle = BorderDayLeftLineStyle
              .Weight = BorderDayLeftWeight
              .Color = BorderDayLeftColor
            End With
          End With
        End If
        With .Cells(RowCrnt, ColCrnt)
          With .Borders(xlEdgeBottom)
            .LineStyle = BorderDayLeftLineStyle
            .Weight = BorderDayLeftWeight
            .Color = BorderDayLeftColor
          End With
        End With
      Next
      ' Set right border for month
      With .Cells(RowCrnt, ColEndNewMonth)
        With .Borders(xlEdgeRight)
          .LineStyle = BorderMonthRightLineStyle
          .Weight = BorderMonthRightWeight
          .Color = BorderMonthRightColor
        End With
      End With
    Next

  End With

End Sub
Function ColNumToCode(ByVal ColNum As Long) As String

  Dim ColCode As String
  Dim PartNum As Long

  ' Last updated 3 Feb 12.  Adapted to handle three character codes.

  If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    ColCode = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      ColCode = Chr(65 + PartNum) & ColCode
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

  ColNumToCode = ColCode

End Function

使用Excel和VBA，我想自动填充包含开始日期和结束日期的日历

1 个答案: