如何使用VBA excel执行涉及日期的循环？

我需要从包含日期标准的工作表中获取值。日期范围为1月1日至1月31日。我做了一些编码，但老实说，循环不太好。希望你能帮我做这些。 所以过程是，我过滤数据，例如，对于B列，我过滤1月1日，然后A列的数据将被复制并粘贴到另一张表上。在那之后，我在1月2日再次过滤，从A列复制数据并再次粘贴到另一张表上，依此类推

Option Explicit

Sub Macro2()
'
' Macro2 Macro
'
'

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With



    Sheets("Data").Select
    ActiveSheet.Range("$A$1:$B$1000").AutoFilter Field:=2, Operator:= _
        xlFilterValues, Criteria2:=Array(2, "1/1/2019")
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("January").Select
    Range("P5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("P:P").EntireColumn.AutoFit
    Range("A1").Select
    Sheets("Data").Select
    ActiveSheet.Range("$A$1:$B$1000").AutoFilter Field:=2
    Range("A1").Select


    Sheets("Data").Select
    ActiveSheet.Range("$A$1:$B$1000").AutoFilter Field:=2, Operator:= _
        xlFilterValues, Criteria2:=Array(2, "1/2/2019")
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("January").Select
    Range("Q5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("Q:Q").EntireColumn.AutoFit
    Range("A1").Select
    Sheets("Data").Select
    ActiveSheet.Range("$A$1:$B$1000").AutoFilter Field:=2
    Range("A1").Select


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

• 如果您只希望所有日期都从2019年1月开始，并且不担心它们在

  1月

  工作表上的显示顺序，您可以去掉循环（在下面的代码中）并指定一次：“大于或等于2019年1月1日”和“小于2019年2月1日”。（它应该比循环快，但输出顺序将反映/匹配原始工作表上的内容。）
• 另一方面，如果确定要循环，可以尝试下面的代码。一旦您知道代码工作正常，

  应用程序

  设置可以取消注释。（我无法测试，因为我不知道您的工作表是什么样子。）
• 我的筛选条件假设日期的小时、分钟和秒分量都是

  0

  。如果不是这样，您可能需要相应地调整

  Criteria1

  和

  Criteria2

• 目前，输出将是连续的。例如，假设您的

  数据表如下所示：
  
  包含2019年1月28日的
  
  不包含2019年1月29日的
  
  包含2019年1月30日的
  
  

• 然后输出将类似于：
  • 2019年1月28日

    的数据在某些列中

  • 2019年1月30日<代码>的数据见下一列
• 换言之，输出中不存在反映“缺失日期”的空白列。如果你没有任何“错过日期”，这不是问题。但是，如果您的

  一月

  工作表需要一个空白列（对于每个缺少的日期），您可以将

  pasteOffset=pasteOffset+1

  行移到if之外（在它之后）

---

选项显式
Sub Macro2（）'需要重命名。
应用
'.ScreenUpdating=False
'.EnableEvents=False
以
将源表设置为工作表
Set sourceSheet=工作表（“数据”）
将目的表设置为工作表
Set destinationSheet=Worksheets（“一月”）'也可以在循环中动态确定这一点，而不是在此处硬编码。
destinationSheet.Cells.Clear
Dim包括标题作为范围
Set includingHeaders=sourceSheet.Range（“A1:B1000”）
Dim（不包括作为范围的加载器）
设置excludingHeaders=includingHeaders.Offset（1）。调整大小（includingHeaders.Rows.Count-1，1）
Dim dateIndex作为日期
对于dateIndex=DateSerial（2019，1，1）到DateSerial（2019，1，31）”，可以使用日期文字来代替（如果您愿意的话）。
“不确定这是否是准确匹配日期的最佳方式。
includingHeaders.AutoFilter字段：=2，标准1:=“>=”&CLng（日期索引），运算符：=xlAnd，标准2:=“您遇到了什么问题？您是否遇到了错误？”循环不好-什么循环？事实上，到目前为止没有错误，问题是我现在的想法非常糟糕，比如复制这部分内容，然后更改日期直到1月31日ActiveSheet.Range（$A$1:$B$1000”）。自动筛选字段：=2，运算符：=\uxlFilterValue，准则2:=Array（2，***/*****）从1月1日到1月31日，是否有一种编码方式？我知道这有点像是一个noob问题。但这是我能做的最远的了
Can also consider do so:

Sub TransferDate()

For Each cell In Worksheets("Data2").Columns(1).Cells
    If cell.Value = "" Then Exit Sub

    If IsDate(cell.Value) Then
        Mth = MonthName(Month(cell.Value))
        DayDate = Day(cell.Value)
        Worksheets(Mth).Cells(Rows.Count, DayDate + 15).End(xlUp).Offset(1).Value = cell.Value
        Worksheets(Mth).Columns(DayDate + 15).EntireColumn.AutoFit
    End If
Next

End Sub

Option Explicit

Sub Macro2() ' Needs renaming.

    With Application
        '.ScreenUpdating = False
        '.EnableEvents = False
    End With

    Dim sourceSheet As Worksheet
    Set sourceSheet = Worksheets("Data")

    Dim destinationSheet As Worksheet
    Set destinationSheet = Worksheets("January") ' Could also determine this dynamically inside the loop, rather than hardcoding here.
    destinationSheet.Cells.Clear

    Dim includingHeaders As Range
    Set includingHeaders = sourceSheet.Range("A1:B1000")

    Dim excludingHeaders As Range
    Set excludingHeaders = includingHeaders.Offset(1).Resize(includingHeaders.Rows.Count - 1, 1)

    Dim dateIndex As Date
    For dateIndex = DateSerial(2019, 1, 1) To DateSerial(2019, 1, 31) ' Could use date literals instead (if you wanted to).
        ' Not sure if this is the best way to exactly match a date.
        includingHeaders.AutoFilter Field:=2, Criteria1:=">=" & CLng(dateIndex), Operator:=xlAnd, Criteria2:="<=" & CLng(dateIndex)

        ' Range.SpecialCells method is called twice, which is inefficient.
        If includingHeaders.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            excludingHeaders.SpecialCells(xlCellTypeVisible).Copy

            Dim pasteOffset As Long
            destinationSheet.Range("P5").Offset(0, pasteOffset).PasteSpecial xlPasteValuesAndNumberFormats
            pasteOffset = pasteOffset + 1 ' This is only incremented if the date exists in column B.
        End If
    Next dateIndex

    sourceSheet.AutoFilterMode = False

    With Application
        .CutCopyMode = False
        '.ScreenUpdating = True
        '.EnableEvents = True
    End With
End Sub