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经典代码实践指南
查看: 356|回复: 19

[已解决] 求助:用VBA数组求出每种产品近期的消耗量

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-2-12 16:12 | 显示全部楼层 |阅读模式
本帖最后由 laojiu369 于 2020-2-18 11:40 编辑

各位老师:       B列列出近期每天各种产品的消耗量,H1单元格列出了全部产品型号。

       现求助,请用VBA数组(B列一个数组,H1一个数组),求出每种产品近期消耗量。
预谢!

详见附件。
新建 Microsoft Excel 工作表.rar (5.26 KB, 下载次数: 20)

TA的精华主题

TA的得分主题

发表于 2020-2-12 16:39 | 显示全部楼层
字典的简单应用,无非涉及字符串的拆分(split)

TA的精华主题

TA的得分主题

发表于 2020-2-12 16:42 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-2-12 16:51 | 显示全部楼层
本帖最后由 鄂龙蒙 于 2020-2-12 21:52 编辑
  1. <blockquote>Sub 统计()
复制代码

评分

参与人数 1鲜花 +2 收起 理由
laojiu369 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-2-12 16:53 | 显示全部楼层
本帖最后由 鄂龙蒙 于 2020-2-12 21:48 编辑

请测试:
求出每种产品近期的消耗量.rar (9.87 KB, 下载次数: 3)

TA的精华主题

TA的得分主题

发表于 2020-2-12 16:56 | 显示全部楼层
  1. Option Explicit

  2. Sub Main()
  3.     Dim sh As Worksheet, lngRow As Long, arrData As Variant
  4.     Dim objDic As Object, strKey As String
  5.     Dim arrKeys As Variant, arrItems As Variant
  6.    
  7.     Set sh = Sheets("Sheet1")
  8.     Set objDic = CreateObject("Scripting.Dictionary")
  9.     '将型号装入字典,并赋值为0
  10.     strKey = sh.Range("H1").Value
  11.     SetDic objDic, strKey
  12.    
  13.     '读取产品型号
  14.     lngRow = sh.Range("B" & Rows.Count).End(xlUp).Row
  15.     arrData = sh.Range("B2:B" & lngRow)
  16.    
  17.     For lngRow = LBound(arrData) To UBound(arrData)
  18.         strKey = arrData(lngRow, 1)
  19.         '将产品装入字典,并一次 +1
  20.         SetDic objDic, strKey, 1
  21.     Next
  22.    
  23.     lngRow = objDic.Count
  24.     If lngRow > 0 Then
  25.         arrKeys = objDic.keys
  26.         arrItems = objDic.Items
  27.         
  28.         sh.Range("D:E").Clear
  29.         sh.Range("D1").Resize(lngRow, 1) = Application.WorksheetFunction.Transpose(arrKeys)
  30.         sh.Range("E1").Resize(lngRow, 1) = Application.WorksheetFunction.Transpose(arrItems)
  31.     End If
  32.    
  33.     Set objDic = Nothing
  34.     MsgBox "OK"
  35. End Sub


  36. Function SetDic(objDic As Object, strID As String, Optional lngAdd As Long = 0, Optional strChar As String = " ")
  37.     Dim strSplit() As String, lngID As Long, strKey As String
  38.    
  39.     strSplit = Split(strID, strChar)
  40.    
  41.     For lngID = LBound(strSplit) To UBound(strSplit)
  42.         strKey = Trim(strSplit(lngID))
  43.         If strKey <> "" Then objDic(strKey) = objDic(strKey) + lngAdd
  44.     Next
  45. End Function
复制代码

评分

参与人数 1鲜花 +2 收起 理由
laojiu369 + 2 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-2-12 17:00 | 显示全部楼层
Sub test()
Dim brr(1 To 100, 1 To 2)
arr = Split([h1], " ")
For i = 0 To UBound(arr)
    For j = 2 To Cells(Rows.Count, 2).End(xlUp).Row
        If InStr(Cells(j, 2), arr(i)) Then
            n = n + 1
        End If
    Next
    brr(i + 1, 1) = arr(i)
    brr(i + 1, 2) = n
    n = 0
Next
[g2].Resize(UBound(arr) + 1, 2) = brr
End Sub

评分

参与人数 1鲜花 +2 收起 理由
laojiu369 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-12 18:17 | 显示全部楼层
衷心感谢老版主蓝桥玄霜、鄂龙蒙、lsdongjh、sdc3211772几位老师出手相助,初步试了一下,总的感觉:一个字“爽”,三个字“爽极了”,实在是佩服!向各位学习了!水平有限,需要慢慢消化,再次表示感谢!好人一生平安!

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-12 21:01 | 显示全部楼层
各位老师:
       我又有一个新的想法,如果我想把近期产品消耗在5-8台之间的型号,用空格作间隔,集中显示在某个单元格内,比如H2,代码又应该怎样修改呢?还请各位不吝赐教。

TA的精华主题

TA的得分主题

发表于 2020-2-13 00:09 | 显示全部楼层
Sub hh()
    Dim arr, brr(1 To 10000, 1 To 2)
    r = Cells(Rows.Count, 2).End(xlUp).Row
    arr = Range("b2:b" & r).Value
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        s = Split(arr(i, 1), " ")
        For x = 0 To UBound(s)
            If Not d.exists(s(x)) Then
                k = k + 1
                d(s(x)) = k
                brr(k, 1) = s(x)
                brr(k, 2) = 1
            Else
                r = d(s(x))
                brr(r, 2) = brr(r, 2) + 1
            End If
        Next
    Next
    Dim a(1 To 4, 1 To 2)
    For i = 1 To 4
        a(i, 1) = i + 4
    Next
    For i = 1 To 4
        For j = 1 To k
            If brr(j, 2) = a(i, 1) Then a(i, 2) = a(i, 2) & " " & brr(j, 1)
        Next
    Next
    [d2].Resize(4, 2) = a
    [d7].Resize(k, 2) = brr
End Sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

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

GMT+8, 2020-6-7 18:23 , Processed in 0.089494 second(s), 21 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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