Excel VBA数据生成循环

Question

我有一个工作表，我需要填充两个日期之间的所有日子，一个月54次。

我已经收集了一个循环，可以在第一部分做到这一点-我现在需要ti复制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

​

​

谢谢

Answer 1

刚才看到评论了。是的，代码审查会很好。您可能希望将整个进程移动到数组中。

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

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

tl;dr;

基本原理是，您需要一个从1增加到54的外部循环。然后，从开始日期到结束日期递增的内环。我将日期视为一个长时间，并简单地将其添加到startDate中，直到到达内部循环中的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数组和工作表范围值得一读，长时间使用更通用的VBA阵列。

Answer 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