【VBA求助】--样本-根据原产国将相应数据放在不同的sheet中

蓝无领

请大家帮忙看看是否有VBA可以实现以下功能，谢谢 。
模拟结果，及数据， 请参看附件 样本-根据原产国将相应数据放在不同的sheet中.zip (7.37 KB, 下载次数: 7)

2013-12-19 19:45 上传

点击文件名下载附件

1.根据“汇总表”sheet中的I列的“原产国”进行分类
2.“汇总表”sheet中的I列有几个原产国，就自动加入以原产国代码命名的Sheet（例如样本“CN”，“CO”和“DE”）
3.“汇总表”sheet中相应的记录复制到相应的sheet中（例如将原产国为”CN“的记录复制到”CN“sheet中，并将SN重新按照1开始排序（参考样本“CN”，“CO”和“DE”的模拟结果）

zhaogang1960

请测试：

1. Sub Macro1()
   
2.     Dim arr, brr, sh As Worksheet, d As Object, k, t, a, i&, j&, m&, l&, s$
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = [a1].CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         d(arr(i, 9)) = d(arr(i, 9)) & "," & i
   
8.     Next
   
9.     k = d.Keys
   
10.     t = d.Items
    
11.     brr = arr
    
12.     On Error Resume Next
    
13.     With Worksheets
    
14.         For i = 0 To d.Count - 1
    
15.             m = 1
    
16.             a = Split(t(i), ",")
    
17.             For j = 1 To UBound(a)
    
18.                 m = m + 1
    
19.                 brr(m, 1) = j
    
20.                 For l = 2 To UBound(arr, 2)
    
21.                     brr(m, l) = arr(a(j), l)
    
22.                 Next
    
23.             Next
    
24.             Set sh = .Item(k(i))
    
25.             If sh Is Nothing Then '该工作表不存在则插入一个空工作表
    
26.                 .Add(After:=.Item(.Count - 1)).Name = k(i)
    
27.                 ActiveSheet.[a1].Resize(m, l - 1) = brr
    
28.             Else
    
29.                 sh.Cells.ClearContents
    
30.                 sh.[a1].Resize(m, l - 1) = brr
    
31.             End If
    
32.         Next
    
33.     End With
    
34.     Application.ScreenUpdating = True
    
35. End Sub

复制代码

zhaogang1960

有工作表则先删除原来数据，再写数据，没有工作表则插入一个
请看附件
样本-根据原产国将相应数据放在不同的sheet中.rar (10.95 KB, 下载次数: 8)

2013-12-19 20:14 上传

点击文件名下载附件

蓝无领

zhaogang1960 发表于 2013-12-19 19:56
有工作表则先删除原来数据，再写数据，没有工作表则插入一个
请看附件

谢谢赵版的回复，我刚刚测试了一下，只能出来四个，其余的出不来？

CN
CO
DE
FR
HK
JP
MY
NL
RU
TH
TT
TW
UG
US
ZA

zhaogang1960

蓝无领 发表于 2013-12-19 20:04
谢谢赵版的回复，我刚刚测试了一下，只能出来四个，其余的出不来？

CN

漏了一句Set sh = Nothing：

1. Sub Macro1()
   
2.     Dim arr, brr, sh As Worksheet, d As Object, k, t, a, i&, j&, m&, l&, s$
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = [a1].CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         d(arr(i, 9)) = d(arr(i, 9)) & "," & i
   
8.     Next
   
9.     k = d.Keys
   
10.     t = d.Items
    
11.     brr = arr
    
12.     On Error Resume Next
    
13.     With Worksheets
    
14.         For i = 0 To d.Count - 1
    
15.             m = 1
    
16.             a = Split(t(i), ",")
    
17.             For j = 1 To UBound(a)
    
18.                 m = m + 1
    
19.                 brr(m, 1) = j
    
20.                 For l = 2 To UBound(arr, 2)
    
21.                     brr(m, l) = arr(a(j), l)
    
22.                 Next
    
23.             Next
    
24.             Set sh = .Item(k(i))
    
25.             If sh Is Nothing Then '该工作表不存在则插入一个空工作表
    
26.                 .Add(After:=.Item(.Count - 1)).Name = k(i)
    
27.                 ActiveSheet.[a1].Resize(m, l - 1) = brr
    
28.             Else
    
29.                 sh.Cells.ClearContents
    
30.                 sh.[a1].Resize(m, l - 1) = brr
    
31.                 Set sh = Nothing
    
32.             End If
    
33.         Next
    
34.     End With
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    

复制代码

蓝无领

zhaogang1960 发表于 2013-12-19 20:13
漏了一句Set sh = Nothing：

赵版，我刚刚测试时，发现如果仅仅保留“汇总表”一个 sheet时，VBA无法运行，这个是bug吗？

zhaogang1960

蓝无领 发表于 2013-12-19 20:44
赵版，我刚刚测试时，发现如果仅仅保留“汇总表”一个 sheet时，VBA无法运行，这个是bug吗？

有点问题，为了保证汇总表在最右边：
.Add(Before:=.Item(.Count)).Name = k(i)

1. Sub Macro1()
   
2.     Dim arr, brr, sh As Worksheet, d As Object, k, t, a, i&, j&, m&, l&, s$
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = [a1].CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         d(arr(i, 9)) = d(arr(i, 9)) & "," & i
   
8.     Next
   
9.     k = d.Keys
   
10.     t = d.Items
    
11.     brr = arr
    
12.     On Error Resume Next
    
13.     With Worksheets
    
14.         For i = 0 To d.Count - 1
    
15.             m = 1
    
16.             a = Split(t(i), ",")
    
17.             For j = 1 To UBound(a)
    
18.                 m = m + 1
    
19.                 brr(m, 1) = j
    
20.                 For l = 2 To UBound(arr, 2)
    
21.                     brr(m, l) = arr(a(j), l)
    
22.                 Next
    
23.             Next
    
24.             Set sh = .Item(k(i))
    
25.             If sh Is Nothing Then '该工作表不存在则插入一个空工作表
    
26.                 .Add(Before:=.Item(.Count)).Name = k(i)
    
27.                 ActiveSheet.[a1].Resize(m, l - 1) = brr
    
28.             Else
    
29.                 sh.Cells.ClearContents
    
30.                 sh.[a1].Resize(m, l - 1) = brr
    
31.                 Set sh = Nothing
    
32.             End If
    
33.         Next
    
34.     End With
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    

复制代码

蓝无领

zhaogang1960 发表于 2013-12-19 20:50
有点问题，为了保证汇总表在最右边：
.Add(Before:=.Item(.Count)).Name = k(i)

测试过，非常感谢赵版的帮助。
另外，想问一下，有办法自动加边框吗？

zhaogang1960

蓝无领 发表于 2013-12-19 20:56
测试过，非常感谢赵版的帮助。
另外，想问一下，有办法自动加边框吗？

1. Sub Macro1()
   
2.     Dim arr, brr, sh As Worksheet, d As Object, k, t, a, i&, j&, m&, l&, s$
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = [a1].CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         d(arr(i, 9)) = d(arr(i, 9)) & "," & i
   
8.     Next
   
9.     k = d.Keys
   
10.     t = d.Items
    
11.     brr = arr
    
12.     On Error Resume Next
    
13.     With Worksheets
    
14.         For i = 0 To d.Count - 1
    
15.             m = 1
    
16.             a = Split(t(i), ",")
    
17.             For j = 1 To UBound(a)
    
18.                 m = m + 1
    
19.                 brr(m, 1) = j
    
20.                 For l = 2 To UBound(arr, 2)
    
21.                     brr(m, l) = arr(a(j), l)
    
22.                 Next
    
23.             Next
    
24.             Set sh = .Item(k(i))
    
25.             If sh Is Nothing Then '该工作表不存在则插入一个空工作表
    
26.                 .Add(Before:=.Item(.Count)).Name = k(i)
    
27.                 ActiveSheet.[a1].Resize(m, l - 1) = brr
    
28.                 ActiveSheet.[a1].Resize(m, l - 1).Borders.LineStyle = xlContinuous
    
29.             Else
    
30.                 sh.Cells.Clear
    
31.                 sh.[a1].Resize(m, l - 1) = brr
    
32.                 sh.[a1].Resize(m, l - 1).Borders.LineStyle = xlContinuous
    
33.                 Set sh = Nothing
    
34.             End If
    
35.         Next
    
36.     End With
    
37.     Application.ScreenUpdating = True
    
38. End Sub

复制代码

蓝无领

zhaogang1960 发表于 2013-12-19 21:03

非常感谢赵版的帮助