Excel VBA日期生成循环

Question

Excel VBA日期生成循环

3

我有一个表格需要填充两个日期之间的所有日期，共计54个月。我已经编写了一个循环来完成第一个部分，现在需要复制54次。

我已经想出了一个循环来复制和粘贴这个范围，它可以正常工作。但是我想知道是否有一种方法将日期生成循环放在复制循环内，并生成每个日期，而不是复制和粘贴？

我主要是寻找最有效的方法，因为这可能会在未来扩展，所以非常感谢您对我的代码提供任何指导。

Sub WriteDatesLoopTest()

'Disables Screen Flickering on Copy/Paste
Application.ScreenUpdating = False
OffsetValue = 42
'----------------------------------------------
    Dim StartDate       As Range
    Dim EndDate         As Range
    Dim OutputRange     As Range
    Dim ClearRange      As Range
    Dim StartValue      As Variant
    Dim EndValue        As Variant
    Dim DateRangeCopy   As Range
    Dim EmployeeCount   As Range
    Dim MonthValue      As Range
'----------------------------------------------
    Set ClearRange = Range("A9:A39")
    Set StartDate = Range("T4")
    Set EndDate = Range("T5")
    Set OutputRange = Range("A9")
    Set DateRangeCopy = Range("A9:A39")
    Set EmployeeCount = Range("O1")
    Set MonthValue = Range("J1")
    StartValue = StartDate
    EndValue = EndDate

'----------Date Generation Loop----------------

    If EndValue - StartValue <= 0 Then
        Exit Sub
        End If
        ColIndex = 0
            For i = StartValue To EndValue
                OutputRange.Offset(ColIndex, 0) = i
                ColIndex = ColIndex + 1
            Next

'----------Copy & Paste------------------------
n = EmployeeCount
For j = 0 To (n - 1)
    'ClearRange.Offset(OffsetValue * j, 0).ClearContents
    DateRangeCopy.Copy
    With DateRangeCopy.Offset(OffsetValue * j, 0)
      .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
       SkipBlanks = False
    End With

    'Show Status Bar in Bottom Left
    Application.StatusBar = "Progress: " & Format(j / n, "0%")

   Next

'Display Message on completion
MsgBox "Dates Generated"
'Removes 'Walking Ants' From copied selection
Application.CutCopyMode = False
'Enables Screen Flickering on Copy/Paste
Application.ScreenUpdating = True
'Reset Status Bar in Bottom Left
Application.StatusBar = False
'-----------------------------------

    End Sub

谢谢

- Dean Cohen

2

如果您的代码已经可以正常工作，那么如果您正在寻求代码优化，则可能更适合在Code Review Stack Exchange上提出这个问题。 - Pᴇʜ

1

谢谢，我从未意识到这个存在！我会过去那边 :) - Dean Cohen

2个回答

2

子程序执行的任务越少，编写、测试和修改就越容易。因此，我创建了一个函数来生成输出数组。

OffsetValue 的名称有些模糊不清。我使用了 SectionLength 代替它。

Sub AddDates()
    Const OffsetValue = 42
    Dim data() As Variant
    data = getDatesArray(#6/1/2018#, #6/30/2018#)
    With Worksheets("Sheet1")
        .Columns(1).ClearContents
        .Range("A1").Resize(UBound(data)).Value = data
    End With
End Sub

Function getDatesArray(StartDate As Date, EndDate As Date, Optional SectionLength As Long = 42, Optional RepeatCount As Long = 54) As Variant()
    Dim results() As Variant
    Dim count As Long, n As Long
    ReDim results(1 To SectionLength * RepeatCount, 1 To 1)

    If EndDate >= StartDate Then
        Do
            count = count + 1
            For n = 0 To UBound(results) - SectionLength Step SectionLength
                results(n + count, 1) = StartDate
            Next
            StartDate = StartDate + 1
        Loop Until StartDate = EndDate
    End If
    getDatesArray = results
End Function

- TinMan

谢谢，我已经尝试过这个代码，似乎运行良好。但是，我如何将开始和结束日期引用到我的工作表单元格中呢？例如，可以用Range("b1")替换日期吗？ - Dean Cohen

getDatesArray() 的前两个参数是 StartDate 和 EndDate。 - TinMan

那么我不能将 data = getDatesArray(#6/1/2018#, #6/30/2018#) 更改为 data = getDatesArray(Range("J4"), Range("J5"))，例如吗？最终，我需要通过数据验证下拉菜单在表格内部更改日期以获得灵活性。编辑：这个方法可行。 - Dean Cohen

只需将变量传递给函数。data = getDatesArray(startDate, endDate) - TinMan

抱歉，我不明白你所说的“将变量传递给函数”的意思。 - Dean Cohen

显示剩余2条评论

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- QHarr · Accepted Answer

刚看到评论。是的，代码审查会很好。你可能想把整个过程移到一个数组中。

这展示了所有必需的元素。

Option Explicit
Public Sub GenerateDates()
    Const LOOPCOUNT As Long = 54
    Dim i As Long, j As Long
    Dim startDate As Long, endDate As Long, rowCounter As Long
    startDate = CLng(Now)
    endDate = startDate + 7
    Application.ScreenUpdating = False
    With ActiveSheet
        For i = 1 To LOOPCOUNT
            For j = startDate To endDate
                rowCounter = rowCounter + 1
                .Cells(rowCounter, 1) = j
            Next j
             rowCounter = rowCounter + 5 '<== Add gap
        Next i
        .Columns("A").NumberFormat = "m/d/yyyy"
    End With
    Application.ScreenUpdating = True
End Sub

在内存中执行相同的操作（我已经包括了第二个维度，因为你的数据可能有额外的列。我的原则是展示日期随着行间隙递增。）

Option Explicit
Public Sub GenerateDates() '697
    Const LOOPCOUNT As Long = 54      
    Dim i As Long, j As Long
    Dim startDate As Long, endDate As Long, rowCounter As Long
    startDate = CLng(Now)
    endDate = startDate + 7
    Dim ROWGAP As Long: ROWGAP = 41-(Enddate-StartDate)
    Dim outputArr()
    ReDim outputArr(1 To (((endDate - startDate + 1) + ROWGAP) * LOOPCOUNT) - ROWGAP, 1 To 1)
    Application.ScreenUpdating = False
    With ActiveSheet
        For i = 1 To LOOPCOUNT
            For j = startDate To endDate
                rowCounter = rowCounter + 1
                outputArr(rowCounter, 1) = j
            Next j
            rowCounter = rowCounter + ROWGAP '<== Add gap
        Next i
        .Cells(1, 1).Resize(UBound(outputArr), UBound(outputArr, 2)) = outputArr 'This is only with one dimensional
        .Columns("A").NumberFormat = "m/d/yyyy"
    End With
    Application.ScreenUpdating = True
End Sub

简洁版：

原则是有一个外循环从1到54递增，然后有一个内循环从开始日期递增到结束日期。我把日期视为Long类型，并且在内循环中将startDate加1直到达到endDate。 For i = 1 To LOOPCOUNT是正在执行的重复工作...在这里可以使用复制粘贴。在下一次重复之前，我将rowCounter变量增加5以留出一些空行。

第一个版本对每行写入表格进行操作，如.Cells(rowCounter, 1) = j。那是一种昂贵的操作，每次都要“触摸”表。第二个版本执行相同的过程，但直到最后才写入表格。相反，它将内容写入到数组中。这样做速度更快，因为所有操作都在内存中完成（无需访问磁盘）。

我知道数组中会有多少行，因为我知道我将整个过程重复的次数（54），从startDate到endDate的天数（8），以及我添加的填充行数（5）。因此，我可以使用ReDim outputArr(1 To (((endDate - startDate + 1) + ROWGAP) * LOOPCOUNT) - ROWGAP, 1 To 1)来调整数组的大小。我不需要在第54次循环中填充5行，因此将其从总行数中去掉。

了解如何使用数组和工作表中的数据，可以阅读本文VBA Arrays And Worksheet Ranges，以及更一般的VBA Arrays