按月过滤的 VBA 宏，仅将当月的数据粘贴到不同的工作表上

Posted 2023-04-19

【中文标题】按月过滤的 VBA 宏，仅将当月的数据粘贴到不同的工作表上

【英文标题】：VBA Macro that filters by month, pastes data for that month only on different sheet

【发布时间】：2015-07-07 22:05:50

【问题描述】：

我有一张表（名为“UserInput”），其中包含 1959 年至 2013 年（从 1959 年 10 月 1 日开始）的数据

即：

---

                                 "UserInput" Sheet


                Column A           Column C          Column I
                  DATE           UNGAGED FLOW    PERM. WITHDRAWAL & PASS
        Row 24: 10/1/1959             9.3               7.7
                10/2/1959             5.2               6.4
                10/3/1959             6.3               4.3
                10/4/1959             3.8               7.5
                ... 
                ... 
     Row 19839: 12/31/2013            5.5               9.1

我需要编写一个宏，从 A24 开始按month 进行过滤，然后将每天的日期、“未锁定流量”（从 C24 开始）和“允许撤回和通过”（从 I24 开始）值粘贴到其对应的表格（我有单独的表格，分别命名为“OCTOBER”、“NOVEMBER”、“DECEMBER”等，其中包含“未受限制的流量”和“允许的取款和通过”列）

即：

---

                               "OCTOBER" Sheet

              Column A          Column B            Column C
                DATE          UNGAGED FLOW      PERM. WITHDRAWAL & PASS

       Row 3: 10/1/1959           9.3                 7.7
              10/2/1959           5.2                 6.4
              10/3/1959           6.3                 4.3
              ...
              ...
              10/1/1960            n                   n
              10/2/1960            n                   n
              ...
              ...
              10/1/1961            n                   n
              10/2/1961            n                   n
              (etc.)

每个月（10 月到 9 月）以此类推。

这是我目前所拥有的（我是 VBA 的新手，所以不要畏缩）：

Sub getmonths()


Sheets("UserInput").Activate

Dim monthpassby(12) as Double       ' ungaged flow
Dim monthwithdrawal(12) as Double   ' permitted withdrawal and passby
Dim months As Variant

   ' need code to read-in data?

 'check for month in the date
  Sheets("October").Range("A3").Select

  Do Until IsEmpty (Sheets("UserInput").Range("C24").Value)

  months = Month(Sheets("UserInput").Range("A24").Value)

  Sheets("October").Range("A3").Value = monthpassby (months)
  ActiveCell.Offset(0,1) = monthwithdrawal (months)     

  ActiveCell.Offset (1,0).Select

Loop

End Sub

我花了大约一周的时间研究这个问题。我真的需要帮助只是填补中间。我也尝试过使用Advanced_Filter 并录制我的宏。考虑了一个数据透视表，但是我需要每个月份的每张表上的“未计入流量”和“允许的取款和通过”数据来计算另外两个列（“超出值”和“流量”），这也将在个别月表。然后我必须在相应的月表上为每个月生成一个流动持续时间曲线。我没有使用到那种程度的数据透视表，但是如果你知道一种方法，我可以用一个很棒的数据透视表来做到这一点。而且，这最终将成为一个用户输入工具，因此“未管理的流程”和“允许的取款和通过”值将取决于用户拥有的值。

【问题讨论】：

实际上，当您明确引用您需要使用的每张工作表时，这非常好！问题是您没有增加行数。我很快就会给你看一个例子

第一行的月度工作表中是否有未受限制的流和允许的提现和通过列标签？

值的第一个空格从 A3（“日期”列）、B3（“未锁定的流”）和 C3（“允许的取款和通过”）开始

【参考方案1】：

在没有样本数据的情况下，这有些是猜测。

Sub xfer_monthly_data()
    Dim iMON As Long, lc As Long, nrw As Long, ws As Worksheet
    Dim c1 As Long, c2 As Long
    With Sheets("UserInput")
        If .AutoFilterMode Then .AutoFilterMode = False
        .Columns(1).Insert
        With .Range(.Cells(23, 1), .Cells(24, 2).End(xlDown))
            With .Offset(1, 0).Resize(.Rows.Count - 1, 1)
                .FormulaR1C1 = "=MONTH(RC2)"
            End With
            With .Resize(.Rows.Count, 10)
                For iMON = 1 To 12
                    .AutoFilter field:=1, Criteria1:=iMON
                    If CBool(Application.Subtotal(102, .Columns(2))) Then
                        Set ws = Worksheets(UCase(Format(DateSerial(2015, iMON, 1), "mmmm")))
                        c1 = Application.Match("ungaged flow", ws.Rows(1), 0)
                        c2 = Application.Match("permitted withdrawal and passby", ws.Rows(1), 0)
                        nrw = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                        .Offset(1, 1).Resize(.Rows.Count - 1, 1).Copy _
                          Destination:=ws.Cells(nrw, 1)
                        .Offset(1, 3).Resize(.Rows.Count - 1, 1).Copy _
                          Destination:=ws.Cells(nrw, c1)
                        .Offset(1, 9).Resize(.Rows.Count - 1, 1).Copy _
                          Destination:=ws.Cells(nrw, c2)
                    End If
                    .AutoFilter field:=1
                Next iMON
            End With
        End With
        If .AutoFilterMode Then .AutoFilterMode = False
        .Columns(1).Delete
    End With
End Sub

插入一个新列以用作“帮助器”，并使用一个公式确定原始列 A 中日期的数字月份，从而可以轻松应用过滤器。可见单元的批量复制操作总是比遍历单个单元并确定它们的有效性更快。操作完成后，辅助列被移除。

通过关闭屏幕更新、计算和事件（至少）可以进一步加快速度。

【参考方案2】：

这是一个基于您的初始代码的示例：

Option Explicit

Sub GetMonths()
    Dim monthpassby(12) As Double
    Dim monthwithdrawal(12) As Double
    Dim currentMonth As Variant
    Dim wsUserInput As Worksheet
    Dim wsOctober As Worksheet
    Dim i As Long, totalRows As Long

    Set wsUserInput = Worksheets("UserInput")
    Set wsOctober = Worksheets("October")

    totalRows = wsUserInput.UsedRange.Rows.Count

    For i = 24 To totalRows 'iterate through each row on sheet UserInput

        currentMonth = Month(wsUserInput.Range("A" & i).Value2)

        'copy array values to sheet October, column A and B, starting at row 3
        With wsOctober.Range("A" & (i - 21))
            .Value2 = monthpassby(currentMonth)             'Column A
            .Offset(0, 1).Value2 = monthwithdrawal(months)  'Column B
        End With
    Next
End Sub

.

它可能无法完成任务，但如果您确认我的理解，它可以修复：

在 UserInput 表单上，您有类似这样的数据：

        Column A    Column C    Column I
Row 24: 10/1/1959   ungaged1    permitted1
Row 25: 10/2/1959   ungaged2    permitted2
Row 26: 10/3/1959   ungaged3    permitted3
... 
... 
Row N: 12/31/2013   ungagedN    permittedN

代码应该复制：

“ungaged2”和“permitted2”到工作表“February”，第 25 行 “ungaged3”和“permitted3”到工作表“March”，第 26 行

如果是这样，那么在所有“月”表上，命名为“无限制流动”和“允许撤离和通过”列的拼写是否完全相同？

【讨论】：

抱歉，我忘了说明我的日期列格式为 mm/dd/yyyy。所以未加龄的 1-3 和允许的 1-3 都进入“十月”表。如果有帮助，我会进一步完善我的问题。