求各位大神帮忙写个高级分类汇总的VBA，万分感谢！！

2728911088

求各位大神帮忙写个分类汇总的VBA，万分感谢！！祥情见附件。

活在理想的世界

你这个好像是用物料代码来匹配带颜色的几个Sheet，然后做成一张表。
在把做好的表用指令号来去重，将类型归类，再把计划组填进对应的类型？

2728911088

活在理想的世界 发表于 2018-6-23 16:39
你这个好像是用物料代码来匹配带颜色的几个Sheet，然后做成一张表。
在把做好的表用指令号来去重，将类型 ...

用指令号查找全部的物料代码，再用物料代码匹配，麻烦帮忙看看。感谢 感谢！！！

LMY123

2728911088 发表于 2018-6-23 17:31
用指令号查找全部的物料代码，再用物料代码匹配，麻烦帮忙看看。感谢 感谢！！！

不知1839这个数据怎么来的？

2728911088

LMY123 发表于 2018-6-23 19:14
不知1839这个数据怎么来的？

是这2个代码的数量，这2个代码是同一类型的。

指令号	物料代码	物料名称	已发数
FDSGF2018379690	179610509913	FDSF4932646FD	941
FDSGF2018379690	153554608681	FDSF5461646FD	898

opiona

考验转置功力的时候到了

1.     Set SH0 = Worksheets("齐套明细")
   
2.     Set SH1 = Worksheets("任务类型")
   
3.     Rem 各个分表数据
   
4.     StrA = ""
   
5.     For Each SH In Worksheets
   
6.         If InStr(SH.Name, "晶") > 0 Then
   
7.             If StrA <> "" Then StrA = StrA & " UNION ALL "
   
8.             StrA = StrA & "SELECT [物料代码],[物料名称],[计划组],[类别],[类型]"
   
9.             StrA = StrA & " FROM [" & SH.Name & "$]"
   
10.             StrA = StrA & " WHERE LEN([物料代码])>0"
    
11.         End If
    
12.     Next
    
13.     Rem 分类汇总
    
14.     StrB = ""
    
15.     StrB = StrB & "SELECT [指令号],[物料代码],[类型],SUM([已发数]) AS [已发数] FROM ("
    
16.     StrB = StrB & "SELECT A.[指令号],A.[物料代码],A.[物料名称],A.[已发数],A.[计划组]"
    
17.     StrB = StrB & ",IIF(ISNULL(B.[类型])=TRUE,'备件',B.[类型]) AS [类型]"
    
18.     StrB = StrB & " FROM ("
    
19.     StrB = StrB & "SELECT [指令号],[物料代码],[物料名称],[已发数],[计划组]"
    
20.     StrB = StrB & " FROM [" & SH0.Name & "$]"
    
21.     StrB = StrB & ") AS A LEFT JOIN ("
    
22.     StrB = StrB & "SELECT [物料代码],[类型]"
    
23.     StrB = StrB & " FROM (" & StrA & ")"
    
24.     StrB = StrB & ") AS B ON A.[物料代码]=B.[物料代码]"
    
25.     StrB = StrB & ") GROUP BY [指令号],[物料代码],[类型]"
    
26.     Rem SQL进行转置
    
27.     StrSQL = ""
    
28.     StrSQL = StrSQL & "TRANSFORM SUM([已发数])"
    
29.     StrSQL = StrSQL & " SELECT [指令号],[物料代码],'' AS [类型],SUM([已发数]) AS [合计]"
    
30.     StrSQL = StrSQL & " FROM (" & StrB & ")"
    
31.     StrSQL = StrSQL & " GROUP BY [指令号],[物料代码]"
    
32.     StrSQL = StrSQL & " PIVOT [类型]"
    
33.     Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
    
34.     SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, True)
    
35.     Rem 组合类型
    
36.     For X = 1 To UBound(SQLARR, 1)
    
37.         Str类型 = ""
    
38.         For ICOL = 4 To UBound(SQLARR, 2)  '//没有合计时，ICOL=3
    
39.             If IsNumeric(SQLARR(X, ICOL)) = True And Abs(SQLARR(X, ICOL)) > 0 Then
    
40.                 If Str类型 <> "" Then Str类型 = Str类型 & "、"
    
41.                 Str类型 = Str类型 & SQLARR(0, ICOL)
    
42.             End If
    
43.         Next
    
44.         SQLARR(X, 2) = Str类型
    
45.     Next
    
46.     Rem 粘贴数据
    
47.     SH1.Range("A1:IT65536").ClearContents
    
48.     SH1.Range("A1").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR

复制代码

opiona

QQ14885553.rar (148.71 KB, 下载次数: 14)

2018-6-23 20:25 上传

点击文件名下载附件

2728911088

opiona 发表于 2018-6-23 20:20
考验转置功力的时候到了

感谢感谢，我先测试下，

2728911088

opiona 发表于 2018-6-23 20:20
考验转置功力的时候到了

您好，辛苦了，测试了下，还需要改动改动，请您抽空再看看。您的结果是：

指令号	物料代码	类型
FDSGF2018379690	130871799466	ADDJFD
FDSGF2018379690	147016560140	DJFDF
FDSGF2018379690	153554608681	JFEWETE
FDSGF2018379690	179610509913	JFEWETE
FDSGF2018379690	183086777074	备件

我想要的结果应该是：

指令号	类型
FDSGF2018379690	备件、JFEWETE、ADDJFD、DJFDF

一把小刀闯天下

'自己测试一下，估计差不多

Option Explicit

Sub test()
  Dim i, j, dic(3), sht, t, arr, n, cnt, key, s
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  n = 4
  For Each sht In Sheets
    With Sheets(sht.Name)
      If InStr(sht.Name, "晶") Then
        arr = .[a1].CurrentRegion
        For i = 2 To UBound(arr, 1)
          dic(2)(arr(i, 1)) = arr(i, 5) '物料代码->类型
          If Not dic(3).exists(arr(i, 5)) Then
            n = n + 1: dic(3)(arr(i, 5)) = n '类型种类
          End If
        Next
      ElseIf sht.Name = "齐套明细" Then
        arr = .[a1].CurrentRegion
        For i = 2 To UBound(arr, 1)
          dic(1)(arr(i, 1) & arr(i, 2)) = arr(i, 4) '指令、种类->已发数
          If dic(0).exists(arr(i, 1)) Then '每个指令包含的物料代码
            t = dic(0)(arr(i, 1)): ReDim Preserve t(UBound(t) + 1)
            t(UBound(t)) = arr(i, 2): dic(0)(arr(i, 1)) = t
          Else
            dic(0)(arr(i, 1)) = Array(arr(i, 2))
          End If
        Next
      End If
    End With
  Next
  ReDim arr(1 To dic(0).Count, 1 To dic(3).Count + 4)
  For Each key In dic(0).keys
    ReDim n(1 To dic(3).Count + 4)
    cnt = cnt + 1: arr(cnt, 1) = key: s = vbNullString
    t = dic(0)(key) '单个指令中的物料代码
    For i = 0 To UBound(t)
      If dic(2).exists(t(i)) Then '按物料代码获取类型
        If InStr(s, dic(2)(t(i))) = 0 Then s = s & dic(2)(t(i)) & "、"
        n(dic(3)(dic(2)(t(i)))) = n(dic(3)(dic(2)(t(i)))) + dic(1)(key & t(i))
      Else
        s = s & "备件" & "、": n(4) = n(4) + dic(1)(key & t(i))
      End If
    Next
    s = Left(s, Len(s) - 1): arr(cnt, 3) = s '类型
    For i = 4 To UBound(arr, 2): arr(cnt, i) = n(i): Next '不同种类已发数汇总
  Next
  With Sheets("任务类型").[n1] '输出位置自己修改，作比较用
    .Resize(Rows.Count, UBound(arr, 2)).ClearContents
    .Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    .Offset(, 4).Resize(, dic(3).Count) = dic(3).keys
    .Resize(, 4) = Split("指令号  类型 备件")
  End With
End Sub