学习后，参照人家代码做的总清单分类，有问题请教，谢谢

cushion1

各位高手，小弟几天刚学VBA起步，做了份按总清单分类的表，附件： 分类.zip (27.02 KB, 下载次数: 9)

2013-5-11 21:28 上传

点击文件名下载附件

当把以下的常量改成变量时就出错，另外一个问题，如果复制原表的表格格式大小？谢谢啦

grf1973

代码本身没错，好象usedrange后，a=20，应该是你在编辑表的时候在16行之外有操作，可能输入了空格。把16行以后删掉后就正常了。
另外你的代码写得太复杂了，而且只到第2箱，不具有拓展性。

grf1973

把你源代码了一下，重组后剩2个sub。

1. Sub sc()   '删除主表外的其它表
   
2.    Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim sht As Worksheet
   
5.     Dim th As Workbook
   
6.     Set th = ThisWorkbook
   
7.     For Each sht In th.Sheets    '在工作表里循环
   
8.         If sht.Name <> Sheet1.Name Then sht.Delete
   
9.     Next
   
10. End Sub
    
11. Sub 分类()
    
12.     Dim mrng As Range, nsht As Worksheet
    
13.     Application.ScreenUpdating = False
    
14.      Application.DisplayAlerts = False
    
15.     Call sc  '删除主表外的其它表
    
16.     Set d = CreateObject("scripting.dictionary")
    
17.     With Sheets(1)
    
18.         a = .[a65536].End(3).Row
    
19.         arr = .Range("a6:k" & a)
    
20.         For i = 1 To UBound(arr)
    
21.            d(arr(i, 11)) = ""
    
22.         Next
    
23.         brr = d.keys     '第11列（K）列去重，存入brr数组
    
24.         For i = 0 To UBound(brr)
    
25.             xh = Mid(brr(i), 8, 1)
    
26.             xh = "第" & xh & "箱"    'xh＝新建工作名
    
27.             Set mrng = .[a1:j5]      '表头
    
28.             For j = 1 To UBound(arr)
    
29.                 If arr(j, 11) = brr(i) Then
    
30.                   Set mrng = Union(mrng, .Cells(j + 5, 1).Resize(1, 10))   '合并相同箱号区域
    
31.                 End If
    
32.             Next
    
33.             Sheets.Add after:=Sheets(Sheets.Count)
    
34.             Set nsht = ActiveSheet
    
35.             nsht.Name = xh
    
36.             mrng.Copy nsht.[a1]
    
37.             r = nsht.[a65536].End(3).Row
    
38.             For k = 6 To r        '重编序号
    
39.                 nsht.Cells(k, 1) = k - 5
    
40.             Next
    
41.             .Range("o1:x2").Copy nsht.Cells(r + 1, 1)     '表尾
    
42.              nsht.Cells(r + 1, 3).Formula = "=SUM(c6:c" & r & ")"
    
43.             nsht.Cells(r + 1, 7).Formula = "=SUM(g6:g" & r & ")"
    
44.         Next
    
45.         .Activate
    
46.     End With
    
47.     Application.ScreenUpdating = True
    
48.     Application.DisplayAlerts = True
    
49. End Sub
    

复制代码

cushion1

grf1973 发表于 2013-5-12 15:33
把你源代码了一下，重组后剩2个sub。

好强，太谢谢你了，你整理后简洁多了，真不好意思，还有一个问题请教你一下，就是如何把源表的格式，如列宽和行高，一样的复制过去

cushion1

grf1973 发表于 2013-5-12 15:33
把你源代码了一下，重组后剩2个sub。

还有一个问题，你用的是end属性，如果源表数据有隐藏的行，可能会有问题

grf1973

1、用隐藏的话用end属性的确会出问题。
2、要源表格式一起过去的话，在分类里面把mrng定义为整行。拷贝后再把多余的列删掉。

1. Sub 分类()
   
2.     Dim mrng As Range, nsht As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.      Application.DisplayAlerts = False
   
5.     Call sc  '删除主表外的其它表
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     With Sheets(1)
   
8.         a = .[a65536].End(3).Row
   
9.         arr = .Range("a6:k" & a)
   
10.         For i = 1 To UBound(arr)
    
11.            d(arr(i, 11)) = ""
    
12.         Next
    
13.         brr = d.keys     '第11列（K）列去重，存入brr数组
    
14.         For i = 0 To UBound(brr)
    
15.             xh = Mid(brr(i), 8, 1)
    
16.             xh = "第" & xh & "箱"    'xh＝新建工作名
    
17. '            Set mrng = .[a1:j5]      '表头
    
18.             Set mrng = .Rows("1:5")
    
19.             For j = 1 To UBound(arr)
    
20.                 If arr(j, 11) = brr(i) Then
    
21.                 '  Set mrng = Union(mrng, .Cells(j + 5, 1).Resize(1, 10))   '合并相同箱号区域
    
22.                   Set mrng = Union(mrng, .Rows(j + 5))
    
23.                 End If
    
24.             Next
    
25.             Sheets.Add after:=Sheets(Sheets.Count)
    
26.             Set nsht = ActiveSheet
    
27.             nsht.Name = xh
    
28.             mrng.Copy nsht.[a1]
    
29.             nsht.Columns("K:X").Delete
    
30.             r = nsht.[a65536].End(3).Row
    
31.             For k = 6 To r        '重编序号
    
32.                 nsht.Cells(k, 1) = k - 5
    
33.             Next
    
34.             .Range("o1:x2").Copy nsht.Cells(r + 1, 1)     '表尾
    
35.              nsht.Cells(r + 1, 3).Formula = "=SUM(c6:c" & r & ")"
    
36.             nsht.Cells(r + 1, 7).Formula = "=SUM(g6:g" & r & ")"
    
37.         Next
    
38.         .Activate
    
39.     End With
    
40.     Application.ScreenUpdating = True
    
41.     Application.DisplayAlerts = True
    
42. End Sub

复制代码

grf1973

我测试了一下，只要有隐藏，不管用哪种方式取得最大行，生成的新表中都会有问题。就最大行而言，用currentregion.rows.count始终是对的。请测试代码。

1. Sub test()
   
2.     With Sheets(1)
   
3.         a = .[a65536].End(3).Row
   
4.         b = .UsedRange.Rows.Count
   
5.         c = .[a1].CurrentRegion.Rows.Count
   
6.         Debug.Print a, b, c
   
7.     End With
   
8. End Sub

复制代码