ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

新浪微博登陆

只需一步, 快速开始

    高级搜索
高效办公必会的Office实战技巧 魔方网表,Excel终结者,永久免费 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! 国内首部Excel函数公式学习大典 职场充电黑科技, Office微视频教程 免费下载Excel行业应用视频
买教程送最新正版Office 2016! Tableau-数据可视化工具 免费阅读《Excel函数其实很简单Ⅱ》 9门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 189|回复: 9

[求助] VBA统计

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-4-21 13:43 | 显示全部楼层 |阅读模式
你好,
表1中“厂商名称”有多个且都有重复,要求在表2中记录所有的厂商(不能重复),并统计相应厂商的“验货总数”(求和)、A和B的个数(计数)。
请用VBA编写,多谢!


统计.rar

14.95 KB, 下载次数: 16

TA的精华主题

TA的得分主题

发表于 2017-4-21 14:04 | 显示全部楼层
用一个4列的数组存放结果,用一个字典记录行号,然后,循环原始数据......................................

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-4-21 14:16 | 显示全部楼层
本人新手,请大神编写以便学习,谢谢。

TA的精华主题

TA的得分主题

发表于 2017-4-21 14:48 | 显示全部楼层
用什么代码拉,透视表搞定不就可以拉

TA的精华主题

TA的得分主题

发表于 2017-4-21 14:56 | 显示全部楼层
本帖最后由 粤北一蚯 于 2017-4-21 15:27 编辑
  1. Option Explicit

  2. Sub aa()
  3.     Dim xrow%,  i%, k%, m%
  4.     Dim dic As Object, x$
  5.     Dim arr, brr
  6.     arr = Sheet1.Range("a1").CurrentRegion.Value
  7.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  8.     Set dic = CreateObject("Scripting.dictionary")
  9.     For i = 3 To UBound(arr)
  10.         x = arr(i, 1) & arr(i, 4)
  11.         If dic.Exists(x) Then
  12.             m = dic(x)
  13.             If arr(i, 4) = "A" Then
  14.                 brr(m, 3) = brr(m, 3) + 1
  15.             ElseIf arr(i, 4) = "B" Then
  16.                 brr(m, 4) = brr(m, 4) + 1
  17.             End If
  18.         Else
  19.             k = k + 1
  20.             dic(x) = k
  21.             brr(k, 1) = arr(i, 1)
  22.             brr(k, 2) = brr(k, 2) + arr(i, 3)
  23.             If arr(i, 4) = "A" Then
  24.                 brr(k, 3) = brr(k, 3) + 1
  25.             ElseIf arr(i, 4) = "B" Then
  26.                 brr(k, 4) = brr(k, 4) + 1
  27.             End If
  28.         End If
  29.     Next
  30.     With Sheet2
  31.         xrow = .Range("a1").CurrentRegion.Rows.Count
  32.         If xrow > 2 Then
  33.             .Range([a3], Cells(xrow, 4)).Clear
  34.         End If
  35.         .[a3].Resize(UBound(brr), UBound(brr, 2)) = brr
  36.         With Range("a3", Cells(2 + dic.Count, 4))
  37.             .Borders(xlEdgeLeft).LineStyle = xlContinuous
  38.             .Borders(xlEdgeTop).LineStyle = xlContinuous
  39.             .Borders(xlEdgeBottom).LineStyle = xlContinuous
  40.             .Borders(xlEdgeRight).LineStyle = xlContinuous
  41.             .Borders(xlInsideVertical).LineStyle = xlContinuous
  42.             .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  43.             .HorizontalAlignment = xlCenter
  44.             .VerticalAlignment = xlCenter
  45.         End With
  46.     End With
  47.     Set dic = Nothing
  48.     Erase arr
  49.     Erase brr
  50.     x = ""
  51. End Sub
复制代码


统计.zip

53.07 KB, 下载次数: 5

TA的精华主题

TA的得分主题

发表于 2017-4-21 15:14 | 显示全部楼层
Sub zz()
    Dim d, ar
    Set d = CreateObject("Scripting.Dictionary")
    ar = Sheet1.Range("A1").CurrentRegion
    For i = 3 To UBound(ar)
        If Not d.exists(ar(i, 1)) Then
            s = Array(ar(i, 3), 0, 0)
            If ar(i, 4) = "A" Then s(1) = 1
            If ar(i, 4) = "B" Then s(2) = 1
            d(ar(i, 1)) = s
        Else
            a = d(ar(i, 1)): a(0) = a(0) + ar(i, 3)
            If ar(i, 4) = "A" Then a(1) = a(1) + 1
            If ar(i, 4) = "B" Then a(2) = a(2) + 1
            d(ar(i, 1)) = a
        End If
    Next
    With Sheet2
        .[a3].Resize(d.Count) = Application.Transpose(d.keys)
        .[b3].Resize(d.Count, 3) = Application.Rept(d.items, 1)
    End With
End Sub

TA的精华主题

TA的得分主题

发表于 2017-4-21 15:16 | 显示全部楼层
>>>>>>>>>>>>>>>>>>>>>>>>>



统计.rar (20.22 KB, 下载次数: 22)

评分

参与人数 1鲜花 +2 收起 理由
mrb178 + 2 太强大了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-4-21 15:25 | 显示全部楼层
Sub 查询()
Dim cnn As Object
Dim Sql As String
Set cnn = CreateObject("ADODB.CONNECTION")
Application.ScreenUpdating = False
Sheet1.Columns("A:A").TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 2)
cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=YES'; Data Source=" & ThisWorkbook.FullName
Sql = "select 厂商名称,验货数量 AS T1,0 AS T2 from [sheet1$A2:D] WHERE 类型='A' UNION ALL " _
        & "select 厂商名称,0,验货数量  from [sheet1$A2:D] WHERE 类型='B' "
Sql = "SELECT 厂商名称,SUM(T1)+SUM(T2),SUM(T1),SUM(T2) FROM (" & Sql & ") GROUP BY 厂商名称"
Sheet2.Activate
Range("a3:d999").ClearContents
[a3].CopyFromRecordset cnn.Execute(Sql)
cnn.Close: Set cnn = Nothing
Application.ScreenUpdating = True
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-4-21 15:31 | 显示全部楼层
zax010 发表于 2017-4-21 15:14
Sub zz()
    Dim d, ar
    Set d = CreateObject("Scripting.Dictionary")

不愧是大神,代码也精炼。收藏学习了...也谢谢各位!

TA的精华主题

TA的得分主题

发表于 2017-4-22 15:56 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册 新浪微博登陆

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,每天坐享新鲜教程

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

GMT+8, 2017-5-29 19:24 , Processed in 0.194632 second(s), 30 queries , Gzip On, Memcache On.

Powered by Discuz! X3.3

© 2001-2017 Wooffice Inc.

   

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

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

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