Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

工作中常用的Excel函数公式,全印在一张超大鼠标垫上
查看: 332|回复: 10

[已解决] 代码如何添加:不对指定工作表“分类”进行“汇总”的语句?

[复制链接]
发表于 2019-12-3 19:10 | 显示全部楼层 |阅读模式
本帖最后由 ruhong18 于 2019-12-6 15:42 编辑

Sub 汇总()
     Dim sht As Worksheet
     Dim k As Date
     Dim brr(1 To 600000, 1 To 9)
     k = Sheet7.[J3]
     For Each sht In Sheets
         If sht.Name <> "汇总" Then
             arr = sht.UsedRange.Value
             For i = 4 To UBound(arr) Step 13
                 If arr(i, 10) = k Then
                      For j = i + 2 To i + 5
                      If arr(j, 4) <> "" Then
                     n = n + 1
                     brr(n, 1) = n
                     brr(n, 2) = arr(i, 5)
                     brr(n, 3) = arr(j, 4)
                     brr(n, 5) = arr(j, 7): A = A + arr(j, 7)
                     brr(n, 6) = arr(j, 8): B = B + arr(j, 8)
                     brr(n, 7) = arr(j, 9)
                     brr(n, 8) = arr(j, 10): c = c + arr(j, 10)
                     brr(n, 9) = arr(j, 11)
                     End If
                      Next
                 End If
             Next
         End If
     Next
     n = n + 1
     brr(n, 1) = "合计"
     brr(n, 5) = A: brr(n, 6) = B: brr(n, 8) = c
     Sheet7.UsedRange.Offset(4).ClearContents
     Sheet7.[B5].Resize(n, 9) = brr
End Sub


excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2019-12-4 01:25 | 显示全部楼层
你这个问题我看了好久,就是看不懂:“不对指定工作表汇总”到底是什么意思?
如果不指定工作表就意味着对当前工作表做汇总了,是这个意思吗?
如果是,不指定工作表前缀就行了,两者的差别:
s=worksheets(1).cells(1,1)   ‘读取第一个工作表的a1单元格
s1=cells(1,1)                      '读取当前工作表a1单元格
何为当前工作表?就是执行代码的工作表,也就是开始执行代码时眼睛视野看见的那个工作表。代码是能够更改当前工作表位置的,因此只要不是用代码进行了切换,当前工作表就会一直固定为代码开始执行的那个表。如果用代码切换了,当前工作表也就随之改变了。

你的代码别人看不懂,因为不了解你的数据结构,瞎猜是很困难的事情。
仅就结构而言,你使用 For Each sht In Sheets 循环了所有的表,这种情况下指定或者不指定工作表并没有实际意义,工作表变量 sht 就是你处理数据的当前焦点,这个变量并不是特指哪一个表,是所有表的逐个循环。至于后续的代码,都是用数组在做某种统计或者变换,这个要与具体数据联系起来才好分析。
回复

使用道具 举报

 楼主| 发表于 2019-12-4 09:24 | 显示全部楼层
hfwufanhf2006 发表于 2019-12-4 01:25
你这个问题我看了好久,就是看不懂:“不对指定工作表汇总”到底是什么意思?
如果不指定工作表就意味着对 ...

已上传附件

不对指定的分类那个工作表汇总,其他工作表汇总.zip

26.51 KB, 下载次数: 4

回复

使用道具 举报

发表于 2019-12-5 12:16 | 显示全部楼层

这两天在写年度总结,没及时回复。
先说一声,等有空帮你写。
回复

使用道具 举报

 楼主| 发表于 2019-12-5 13:42 | 显示全部楼层
hfwufanhf2006 发表于 2019-12-5 12:16
这两天在写年度总结,没及时回复。
先说一声,等有空帮你写。

好的,多谢~
回复

使用道具 举报

发表于 2019-12-6 10:27 | 显示全部楼层

代码写好了,你先去试下效果。有一个数据我找不到:颜色,那一栏就只能空着;


你这个表我感觉似曾相识,我似乎也曾写过类似的代码。当然重写一次也没有多大难度。

如果你自己有vba代码基础,可以自己根据需要修改,没基础就不要乱改,尤其是前两个表的顺序不要动,因为代码是指定从第三个表开始汇总到最后一个表,然后把汇总结果写入到当前表中。

下面是一些重要参数的说明,便与你自己修改代码,只对我认为关键的地方做说明:

Dim arr(1 To 100, 6)     '定义数组,分别对应c到J列,但不包含e列的颜色,如果你需要颜色,就把数组列数再增加到 7 ;

    数组的最大行是100,这个我不确定,你根据需要增减;
hs = 5                        '起始行是第5行,前面是表头
ri = Cells(3, "j")           '读出日期
For i = 3 To Worksheets.Count      '从第3个表统计到最后一个,第2个表我不知道是干什么的,我也没管它


        If Worksheets(i).Cells(k, "j") = ri Then   '对符合日起定义的记录进行统计

           For j = 1 To 4      '每个单元最大为 4 行,如果你修改了单元最大行数,这里相应变化

               bz = False       '下面是数组检索,判断是否是重复数据,重复的数据进行合并统计,不重复的新增数据就添加到数组的后面
               For l = 1 To js
                   If Worksheets(i).Cells(k + j + 1, 4) = arr(l, 1) Then
                      bz = True
                      ls = l
                      Exit For
                   End If
               Next l

               If bz Then    '这里是重复数据的处理,只统计数量、重量、金额,文本类型的不需要合并
                  arr(l, 2) = arr(l, 2) + Worksheets(i).Cells(k + j + 1, 7)
                  arr(l, 3) = arr(l, 2) + Worksheets(i).Cells(k + j + 1, 8)
                  arr(l, 5) = arr(l, 2) + Worksheets(i).Cells(k + j + 1, 10)
               Else            '下面是新增的不重复数据,要写入完整的全部数据到数组
                  js = js + 1
                  arr(js, 1) = Worksheets(i).Cells(k + j + 1, 4)
                  arr(js, 2) = Worksheets(i).Cells(k + j + 1, 7)
                  arr(js, 3) = Worksheets(i).Cells(k + j + 1, 8)
                  arr(js, 4) = Worksheets(i).Cells(k + j + 1, 9)
                  arr(js, 5) = Worksheets(i).Cells(k + j + 1, 10)
                  arr(js, 6) = Worksheets(i).Cells(k + j + 1, 11)
               End If

    For k = 1 To js     '把数组写入当前汇总表,颜色那一列是跳过的
        Cells(hs, 2) = hs - 4
        Cells(hs, 3) = Worksheets(i).Name
        Cells(hs, 4) = arr(k, 1)
        Cells(hs, 6) = arr(k, 2)
        Cells(hs, 7) = arr(k, 3)
        Cells(hs, 8) = arr(k, 4)
        Cells(hs, 9) = arr(k, 5)
        Cells(hs, 10) = arr(k, 6)
        hs = hs + 1
    Next k

下面是写入最后的总合计,用的是sum函数。用代码汇总也行,只是觉得没必要。工作表函数我认为就这个是可以随便用的,其他的不建议用:
Cells(hs, 2) = "合 计"
Cells(hs, 6) = "=sum(f5:f" & hs - 1 & ")"
Cells(hs, 7) = "=sum(g5:g" & hs - 1 & ")"
Cells(hs, 9) = "=sum(i5:i" & hs - 1 & ")"



汇总工作表.rar

46.13 KB, 下载次数: 2

评分

参与人数 1学分 +2 收起 理由
ruhong18 + 2 学习

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2019-12-6 11:50 | 显示全部楼层
hfwufanhf2006 发表于 2019-12-6 10:27
代码写好了,你先去试下效果。有一个数据我找不到:颜色,那一栏就只能空着;

首先非常感谢您这么详细代码和耐心的指定,经测试,总体方向和效果是达到理想,就是有一个工作表经测试,条数是对的,但是重量有误(不知不是是您说的找不到数据),另外一个就是只要提取每个单据里面的4行内容就可以,不用对它进行合并汇总;
回复

使用道具 举报

发表于 2019-12-6 12:42 | 显示全部楼层
ruhong18 发表于 2019-12-6 11:50
首先非常感谢您这么详细代码和耐心的指定,经测试,总体方向和效果是达到理想,就是有一个工作表经测试, ...

测试代码的时候,统计出来的数据与你的样本结果是一模一样的我才发上去的。
如有不对,你具体说出来是哪一个数据,我好查找原因。
回复

使用道具 举报

 楼主| 发表于 2019-12-6 14:01 | 显示全部楼层
本帖最后由 ruhong18 于 2019-12-6 14:04 编辑
hfwufanhf2006 发表于 2019-12-6 12:42
测试代码的时候,统计出来的数据与你的样本结果是一模一样的我才发上去的。
如有不对,你具体说出来是哪 ...

您好,已上传待修改附件,出错位置用颜色标记着,黄色位置重量不对,麻烦您看下~  还有看看能否保存为2003版本的,如果没有就算,不用2003也可以

待修改.zip

46.05 KB, 下载次数: 1

回复

使用道具 举报

发表于 2019-12-6 15:05 | 显示全部楼层
ruhong18 发表于 2019-12-6 14:01
您好,已上传待修改附件,出错位置用颜色标记着,黄色位置重量不对,麻烦您看下~  还有看看能否保存为200 ...

1、有一个的地方的代码有问题,你自己修改,我不上传了,具体位置:
               If bz Then
                  arr(l, 2) = arr(l, 2) + Worksheets(i).Cells(k + j + 1, 7)
                  arr(l, 3) = arr(l, 2) + Worksheets(i).Cells(k + j + 1, 8)     '把 arr(l,2) 改成 arr(l,3),中间是字母L的小写,不是数字1或者字母i
                  arr(l, 5) = arr(l, 2) + Worksheets(i).Cells(k + j + 1, 10)   '把 arr(l,2) 改成 arr(l,5)
      当时是先写好一行,后面用了复制,但参数忘记改了;
      这个错误也很明显,arr(l,3) 不可能与 arr(l,2) 相加,当然是对自己 arr(l,3) 累加了;
      修改后的结果:
                  arr(l, 3) = arr(l, 3) + Worksheets(i).Cells(k + j + 1, 8)
                  arr(l, 5) = arr(l, 5) + Worksheets(i).Cells(k + j + 1, 10)


2、关于版本,我没有2003,你就把代码复制,再粘贴到2003版本即可

评分

参与人数 1学分 +2 收起 理由
ruhong18 + 2 学习

查看全部评分

回复

使用道具 举报

*滑块验证:
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2020-8-4 19:50 , Processed in 0.078000 second(s), 4 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表