使用VBA将当前月份后三个月的数据复制到新工作簿

需求说明 #

现有存储在Sales Workbook.xlsx中的2023年1-12月销售数据，需用VBA实现：以当前系统月份为基准，将后续3个月的数据复制到新工作簿。例：当前是6月则复制7-9月数据，当前是7月则复制8-10月数据。

示例数据参考结构 #

假设Sales Workbook.xlsx的Sheet1数据结构如下（第一行为表头）：

优化后的VBA代码 #

Sub CopyNextThreeMonthsData()
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim newWB As Workbook
    Dim currentMonth As Integer
    Dim startMonth As Integer
    Dim endMonth As Integer
    Dim lastRow As Long
    Dim i As Long
    
    ' 打开源工作簿（未打开时执行）
    On Error Resume Next
    Set sourceWB = Workbooks("Sales Workbook.xlsx")
    On Error GoTo 0
    If sourceWB Is Nothing Then
        Set sourceWB = Workbooks.Open("C:\你的文件路径\Sales Workbook.xlsx") ' 替换为实际文件路径
    End If
    
    Set sourceWS = sourceWB.Sheets("Sheet1") ' 替换为实际数据工作表名称
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
    
    ' 获取当前系统月份
    currentMonth = Month(Date)
    ' 计算起始和结束月份
    startMonth = currentMonth + 1
    endMonth = currentMonth + 3
    
    ' 处理跨年情况（如当前11月，复制12、1、2月）
    If endMonth > 12 Then
        endMonth = endMonth - 12
    End If
    
    ' 创建新工作簿
    Set newWB = Workbooks.Add
    
    ' 复制表头到新工作簿
    sourceWS.Rows(1).Copy Destination:=newWB.Sheets(1).Rows(1)
    
    ' 遍历源数据，复制符合条件的行
    For i = 2 To lastRow
        ' 提取单元格中的月份数字（适配"1月""2月"格式）
        Dim cellMonth As Integer
        cellMonth = Val(Left(sourceWS.Cells(i, "A").Value, InStr(sourceWS.Cells(i, "A").Value, "月") - 1))
        
        ' 判断是否在目标月份范围内
        If startMonth <= 12 Then
            If cellMonth >= startMonth And cellMonth <= endMonth Then
                sourceWS.Rows(i).Copy Destination:=newWB.Sheets(1).Cells(newWB.Sheets(1).Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        Else
            ' 跨年逻辑：匹配大于起始月或小于等于结束月的行
            If cellMonth >= startMonth Or cellMonth <= endMonth Then
                sourceWS.Rows(i).Copy Destination:=newWB.Sheets(1).Cells(newWB.Sheets(1).Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        End If
    Next i
    
    ' 自动调整新工作簿列宽
    newWB.Sheets(1).Columns.AutoFit
    
    MsgBox "后续三个月数据已复制到新工作簿！", vbInformation
End Sub

代码适配说明 #

• 路径替换：将代码中的C:\你的文件路径\Sales Workbook.xlsx替换为实际文件存储路径；若源工作簿已打开，可跳过路径判断部分。
• 工作表适配：将Sheet1替换为实际存储销售数据的工作表名称。
• 月份格式兼容：如果你的数据A列是纯数字（如1、2...12），直接把cellMonth = Val(...)改为cellMonth = sourceWS.Cells(i, "A").Value即可。
• 跨年处理：自动适配10/11/12月的跨年复制需求，无需额外修改。

内容的提问来源于stack exchange，提问作者Thennarasu