ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 187|回复: 4

[求助] 同类组合求和,出错求助

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-1-29 01:14 | 显示全部楼层 |阅读模式
本帖最后由 Chiyuen 于 2020-1-29 02:22 编辑

麻烦大神帮看下这段代码,是想在多个表内,进行同类组合求和,如果去掉最外层的For循环,把Sheets(l)改成常量,只操作一张表就没问题,但是我是想对每一张表执行命令,,不知道为什么会错,求助大神们

Sub count_test()


    Dim i As Integer
    Dim arrs() As Variant
    i = 1


For l = 1 To Sheets.Count

    irow = Sheets(l).Range("a65536").End(xlUp).Row
    icolumn = Sheets(l).Range("IV1").End(xlToLeft).Column
    ReDim Preserve arrs(1 To irow, icolumn - 1) '提示下标越界
    For j = 1 To irow Step 1
        strname = Cells(j, 1)
        isfind = False
        k = 0
        For k = 1 To irow
            If arrs(k, 0) = strname Then
                isfind = True
                Exit For
            End If
        Next k
        If isfind Then
            arrs(k, 1) = arrs(k, 1) + Cells(j, 2)
        Else
            arrs(i, 0) = Cells(j, 1)
            arrs(i, 1) = Cells(j, 2)
            i = i + 1
        End If
    Next j


    For k = 1 To irow
        If arrs(k, 0) <> "" Then
           Cells(k, 4) = arrs(k, 0)
           Cells(k, 5) = arrs(k, 1)
        End If
    Next k
Next
End Sub



数据.rar

13.74 KB, 下载次数: 3

TA的精华主题

TA的得分主题

发表于 2020-1-29 08:37 | 显示全部楼层
ReDim arrs(1 To irow, icolumn - 1)

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-29 08:42 | 显示全部楼层
本帖最后由 Chiyuen 于 2020-1-29 08:48 编辑
microyip 发表于 2020-1-29 08:37
ReDim arrs(1 To irow, icolumn - 1)

去掉Preserve后,结果在同一页出现了两遍,另外,也没有循环动作两个表,
在第二行加入,Sheets(l).Select后,可以同时执行两个表,
但是第二个表的的结果不是从第一行开始,而是从第一个表的结果后的一行开始记录

TA的精华主题

TA的得分主题

发表于 2020-1-29 09:06 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-1-29 11:38 | 显示全部楼层
学下字典,简单搞定
  1. Sub hb()
  2.     Dim i, arr, n
  3.     Dim dic
  4.     Set dic = CreateObject("scripting.dictionary")
  5.     Dim sht As Worksheet
  6.     For Each sht In Sheets
  7.         If sht.Name <> "合并" Then
  8.             For i = 1 To sht.UsedRange.Rows.count
  9.                 If Not dic.exists(sht.Cells(i, 1).Value) Then
  10.                     dic(sht.Cells(i, 1).Value) = sht.Cells(i, 2)
  11.                 Else
  12.                     dic(sht.Cells(i, 1).Value) = dic(sht.Cells(i, 1).Value) + sht.Cells(i, 2)
  13.                 End If
  14.             Next
  15.         End If
  16.     Next
  17.     Sheets("合并").Range("a1").Resize(dic.count) = Application.Transpose(dic.keys)
  18.     Sheets("合并").Range("b1").Resize(dic.count) = Application.Transpose(dic.items)
  19. End Sub
复制代码

数据.zip

16.7 KB, 下载次数: 0

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-4-1 09:10 , Processed in 0.064616 second(s), 19 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

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