请教一个按系统月份来循环复制粘贴到所需单元格

mohao

明细表里的L2:M13是固定的，每个月会统计上个月的数据
汇总表里面是要将每年1-12月的明细表的数据复制到里面
现在请教一下怎么能按系统的月份来进行复制
如 现在是3月份，就将明细表里的L2:M13复制到汇总表里面2月下面的D4:E15里面，
如 现在是4月份，就将明细表里的L2:M13复制到汇总表里面3月下面的F4:G15里面，
.........
如 现在是12月份，就将明细表里的L2:M13复制到汇总表里面1月下面的B4:C15里面，
一直这样循环一年12个月
单位的顺序是固定的了，只需处理数据就好

f8b1987

思路一：
1.将表格月份位置写入到字典中
2.获取当前系统月份，msgbox弹窗提示是否执行
3.将系统月份作为key，从字典提取出对应列位置，确定写入范围
4.打开对应表格，复制粘贴

思路二：
1.获取当前系统月份，msgbox弹窗提示是否执行
2.当前月份-1，循环表格判断哪个与它一致，确定对应列位置
3.打开对应表格，复制粘贴

fzxba

按系统月份复制.rar (33.26 KB, 下载次数: 4)

2024-3-6 09:47 上传

点击文件名下载附件

补-按1楼描述重写.zip (33.62 KB, 下载次数: 6)

2024-3-6 10:24 上传

点击文件名下载附件

wengjl

Sub 每月明细汇总()
   
    ' 问题来源：https://club.excelhome.net/threa ... tml?_dsign=065ac418
    ' 时间：2024-3-6
    ' 需求：将每月产生的明细表上的数据，在次月初汇总到按月的汇总表上
    ' 条件：每月产生的明细表数据格式是一样的；数据存放于同一目录中
    ' 汇总的同时，将“明细”表备份到汇总工作簿上。
   
    yf = Month(Date)          ' 取得月份值
    If yf = 1 Then
      bmc = "12月"            ' 电脑系统时间为1月初，则汇总12月的
    Else
      bmc = yf - 1 & "月"     ' 月初汇总上月的数据
    End If
    Dim wb As Workbook                    ' 定义wb为工作簿变量
    Application.DisplayAlerts = False     ' 此句的作用：删除表时不出现“是否删除的对话框”
    myname = ThisWorkbook.Name            ' 这个工作的名称
    mypath = ThisWorkbook.Path            ' 这个工作的路径
    For ii = 1 To Worksheets.Count        ' 按工作表数量循环
       If Worksheets(ii).Name = bmc Then  ' 通过循环判断，来完成指定表名是否存在的查找
          Worksheets(ii).Delete           ' 删除表
          Exit For
       End If
    Next ii                                      ' 这个循环是删除已有数据表
    Sheets.Add.Name = bmc                        ' 增加表，并起名为 BMC 变量中的值
    Sheets(bmc).Move after:=Sheets(Sheets.Count) ' 将刚新增的表移动到最右侧 Cells.Select Selection.NumberFormatLocal = "@"
    Cells.Select
    Selection.NumberFormatLocal = "@"            ' 单元格设置成文本格式
    '---先准备好空表，以备粘贴用
    f = ThisWorkbook.Path & "\明细.xlsx"         ' 为方便判断
    If Dir(f) = "" Then MsgBox "文件不存在！", 64: Exit Sub  ' 如果表不存在，则退出VBA
    Set wb = Workbooks.Open(mypath & "\明细.xlsx")           ' 打开“明细”表
    wb.ActiveSheet.Select                                    ' 选定活动工作表
    Cells.Copy                                               ' 复制整个表
   
    Windows(myname).Activate       ' 切换活动窗口到汇总表
    ActiveSheet.Paste              ' 粘贴，对“明细”表进行备份留存
    Windows("明细.xlsx").Activate  ' 又切换活动窗口到“明细”
    ActiveWindow.Close             ' 关闭刚打开的“明细”工作簿
    Windows(myname).Activate       ' 回到“汇总”工作簿的窗口
    For y = 2 To 24 Step 2
      If Sheets("汇总").Cells(2, y).Value = bmc Then
        kk = y                     ' 确定当前要汇总数据的列位置
      End If
    Next y
    gg = 2    ' 开始数据的汇总
    Do While Not (IsEmpty(Sheets(bmc).Cells(gg, 11).Value))
      hz = 4
      Do While Not (IsEmpty(Sheets("汇总").Cells(hz, 1).Value))
        If Sheets("汇总").Cells(hz, 1).Value = Sheets(bmc).Cells(gg, 11).Value Then
          Sheets("汇总").Cells(hz, kk).Value = Sheets(bmc).Cells(gg, 12).Value
          Sheets("汇总").Cells(hz, kk + 1).Value = Sheets(bmc).Cells(gg, 13).Value
        End If
        hz = hz + 1
      Loop
      gg = gg + 1
    Loop      ' 数据汇总结束
    Application.DisplayAlerts = True
    Sheets("汇总").Select
    Range("A1").Select
End Sub

2007版本测试通过。 因为办公电脑有加密，所以，不发附件
觉得有益，请送鲜花

mohao

wengjl 发表于 2024-3-7 09:51
Sub 每月明细汇总()
   
    ' 问题来源：https://club.excelhome.net/thread-1686185-1-1.html?_dsign= ...

你这里是不是多了一步，将明细表的复制到汇总，再将数据复制到汇总表里？

wengjl

mohao 发表于 2024-3-7 15:10
你这里是不是多了一步，将明细表的复制到汇总，再将数据复制到汇总表里？

我的想法是：你从系统里导出来的，每月都叫明细，当前月的会把以前的覆盖掉。复制到汇总工作簿是保留原始的，以作备份。这是我66岁的经验哦！

在宏开始 的 5行注释中的第5行已作了说明。