[已解决]VBA代码：sheet1一组数据如何自动分类放在sheet2 sheet3

xhzhengzheng

以前网友提问过，sheet1一组数据如何自动分类放在sheet2 sheet3中，贴地址为：http://www.excelpx.com/thread-111304-1-1.html。版主兰色幻想回贴，所写VBA代码如下：

Sub 分类存放()
Dim arr, arr1, arr2()
Dim myrow
myrow = Sheets("sheet1").Range("h65536").End(xlUp).Row - 1
  arr = Sheets("sheet1").Range("a2:h" & myrow + 1)
  Set d = CreateObject("Scripting.Dictionary")
  '取得唯一的分类
  For x = 1 To myrow
    d(arr(x, 8)) = arr(x, 8)
  Next x
  arr1 = d.keys
  For y = 0 To UBound(arr1)
    ReDim arr2(1 To myrow, 1 To 8)
    For x = 1 To myrow
       If arr(x, 8) = arr1(y) Then
          k = k + 1
          For j = 1 To 8
            arr2(k, j) = arr(x, j)
          Next j
       End If
    Next x
    Set mysheet = Sheets.Add
    mysheet.Name = arr1(y)
    mysheet.Range("a1:h1").Value = Sheets("sheet1").Range("a1:h1").Value
    mysheet.Range("a2").Resize(k, 8) = arr2
    Erase arr2
    k = 0
  Next y
End Sub

本人对语句不太熟悉，想请教版主，另一张表，见附件。

第一，如要指定第12列（进货总单ID）为条件列，原语句如何修改。

第二，如果要把条件筛选后，自动生成sheet2 ，sheet3，sheet4，。。。。，原语句中的如何修改，因为原语句自动生成的是按列中名称自动命名的。

第三，如果能自动生成sheet2 ，sheet3，sheet4，。。。。，后，如果sheet2 ，sheet3，sheet4，。。。。中的列，只需取sheet1中，某些列，又如何修改。例如只取sheet1中的，第1，第3，4，5，6，7，8，9列字段，上述语句如何修改。

请版本多多指教，这个案例对日常工作非常重要，如果能够做成，那是提高了很大的效率。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-11-24 10:03

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr, d, w, i&, j%, k%, k2%, s&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. w = Array(1, 3, 4, 5, 6, 7, 8, 9)
   
7. ReDim brr(1 To UBound(arr), 1 To UBound(w) + 1)
   
8. Application.ScreenUpdating = False
   
9. Application.DisplayAlerts = False
   
10. For i = Sheets.Count To 2 Step -1
    
11.     Sheets(i).Delete
    
12. Next
    
13. For i = 2 To UBound(arr)
    
14.     If Not d.exists(arr(i, 12)) Then d(arr(i, 12)) = i Else d(arr(i, 12)) = d(arr(i, 12)) & "," & i
    
15. Next
    
16. a = d.keys: b = d.items
    
17. For i = 0 To d.Count - 1
    
18.     x = Split(b(i), ","): s = 0
    
19.     For j = 0 To UBound(x)
    
20.         s = s + 1
    
21.         For k = 0 To UBound(w)
    
22.             brr(s, k + 1) = arr(x(j), w(k))
    
23.         Next
    
24.     Next
    
25.     With Sheets.Add(after:=Sheets(Sheets.Count))
    
26.         For k2 = 0 To UBound(w)
    
27.             .Cells(1, k2 + 1) = arr(1, w(k2))
    
28.         Next
    
29.         .Range("a2").Resize(s, UBound(w) + 1) = brr
    
30.         .Columns.AutoFit
    
31.         .Name = "Sheet" & i + 2
    
32.     End With
    
33. Next
    
34. Sheet1.Activate
    
35. Application.DisplayAlerts = True
    
36. Application.ScreenUpdating = True
    
37. End Sub

复制代码

跳转到最佳答案楼层

extyg

jcgdmx20141121.rar (34.43 KB, 下载次数: 16)

2014-11-23 16:32 上传

点击文件名下载附件

xhzhengzheng

非常感谢，extyg。

xhzhengzheng

请教一下extyg，自动的表，能不能自动命名为sheet2 ，sheet3，sheet4。。。的，即符合条件列的第一个进货总单ID,生成的是sheet2，第二个进货总单ID,生成的是sheet3，第三个进货总单ID,生成的是sheet4，以此类推，而不是原来的按进货总单ID命名的方式。如果可以，那么此程序该如何修改？

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr, d, w, i&, j%, k%, k2%, s&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. w = Array(1, 3, 4, 5, 6, 7, 8, 9)
   
7. ReDim brr(1 To UBound(arr), 1 To UBound(w) + 1)
   
8. Application.ScreenUpdating = False
   
9. Application.DisplayAlerts = False
   
10. For i = Sheets.Count To 2 Step -1
    
11.     Sheets(i).Delete
    
12. Next
    
13. For i = 2 To UBound(arr)
    
14.     If Not d.exists(arr(i, 12)) Then d(arr(i, 12)) = i Else d(arr(i, 12)) = d(arr(i, 12)) & "," & i
    
15. Next
    
16. a = d.keys: b = d.items
    
17. For i = 0 To d.Count - 1
    
18.     x = Split(b(i), ","): s = 0
    
19.     For j = 0 To UBound(x)
    
20.         s = s + 1
    
21.         For k = 0 To UBound(w)
    
22.             brr(s, k + 1) = arr(x(j), w(k))
    
23.         Next
    
24.     Next
    
25.     With Sheets.Add(after:=Sheets(Sheets.Count))
    
26.         For k2 = 0 To UBound(w)
    
27.             .Cells(1, k2 + 1) = arr(1, w(k2))
    
28.         Next
    
29.         .Range("a2").Resize(s, UBound(w) + 1) = brr
    
30.         .Columns.AutoFit
    
31.         .Name = "Sheet" & i + 2
    
32.     End With
    
33. Next
    
34. Sheet1.Activate
    
35. Application.DisplayAlerts = True
    
36. Application.ScreenUpdating = True
    
37. End Sub

复制代码

xhzhengzheng

非常感谢，dsmch。

xhzhengzheng

dsmch 发表于 2014-11-24 10:03

你好，dsmch，我使用上述语句时，系统出现了编译错误：变量未定义。 a = d.keys: b = d.items，程序不能执行，能不能在我附件的表中，直接试一下，谢谢！

dsmch

………………

xhzhengzheng

xhzhengzheng 发表于 2014-11-24 15:00
你好，dsmch，我使用上述语句时，系统出现了编译错误：变量未定义。 a = d.keys: b = d.item ...

不好意思，程序是正确的，我多写了Option Explicit，所以就报错了，谢谢dsmch。

xhzhengzheng

谢谢extyg、dsmch的热心帮忙，问题已解决。但还有一个分类汇总的问题，如何把明细表中的记录，去除重复，按(进货总单ID)为分类字段，生成只有（业务日期）、（供应商）、（进货总单ID）三个字段的汇总表。