[已解决]VBA用数组 把B列省份或地区拆分成多个工作表

laoau138

VBA用数组   把B列省份或地区拆分成多个工作表

最佳答案

月排行榜 / 总排行榜

chart888

2017-7-3 16:59

1. Sub test()
   
2. Dim Sh As Worksheet
   
3. Dim i&, x&, r&, d
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. For Each Sh In ThisWorkbook.Worksheets
   
6.     d(Sh.Name) = ""
   
7. Next
   
8. arr = [A1].CurrentRegion
   
9.     For i = 2 To UBound(arr)
   
10.         x = Left(arr(i, 2), 2)
    
11.         For Each Sh In Worksheets
    
12.             If Not d.exists(x) Then
    
13.                 ThisWorkbook.Worksheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
14.                 ActiveSheet.Name = x
    
15.                 d(x) = ""
    
16.                 r = Cells(1, 1).CurrentRegion.Rows.Count + 1
    
17.                 Cells(r, 1) = arr(i, 1): Cells(r, 2) = arr(i, 2)
    
18.             Else
    
19.                 Worksheets(x).Activate
    
20.                 r = Cells(1, 1).CurrentRegion.Rows.Count + 1
    
21.                 Cells(r, 1) = arr(i, 1): Cells(r, 2) = arr(i, 2)
    
22.             End If
    
23.         Next
    
24.     Next
    
25. End Sub

复制代码

跳转到最佳答案楼层

chart888

你又出现了，以为你不会出现呢
新疆吐 西藏措 这是啥意思？
你默认取前三个文字？

laoau138

chart888 发表于 2017-7-3 14:17
你又出现了，以为你不会出现呢
新疆吐 西藏措 这是啥意思？
你默认取前三个文字？

不懂就出现了

按默认前三个字

hhzjxss

数据太少了，不好写代码！

chart888

laoau138 发表于 2017-7-3 15:46
不懂就出现了

按默认前三个字

这个你不会？
你确定？？？
以我对你别的代码的了解
这个你绝对可以搞定

hhzjxss

chart888 发表于 2017-7-3 14:17
你又出现了，以为你不会出现呢
新疆吐 西藏措 这是啥意思？
你默认取前三个文字？

其实就取前两个字做省份就行了，没必要取三个字

chart888

1. Sub test()
   
2. Dim Sh As Worksheet
   
3. Dim i&, x&, r&, d
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. For Each Sh In ThisWorkbook.Worksheets
   
6.     d(Sh.Name) = ""
   
7. Next
   
8. arr = [A1].CurrentRegion
   
9.     For i = 2 To UBound(arr)
   
10.         x = Left(arr(i, 2), 2)
    
11.         For Each Sh In Worksheets
    
12.             If Not d.exists(x) Then
    
13.                 ThisWorkbook.Worksheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
14.                 ActiveSheet.Name = x
    
15.                 d(x) = ""
    
16.                 r = Cells(1, 1).CurrentRegion.Rows.Count + 1
    
17.                 Cells(r, 1) = arr(i, 1): Cells(r, 2) = arr(i, 2)
    
18.             Else
    
19.                 Worksheets(x).Activate
    
20.                 r = Cells(1, 1).CurrentRegion.Rows.Count + 1
    
21.                 Cells(r, 1) = arr(i, 1): Cells(r, 2) = arr(i, 2)
    
22.             End If
    
23.         Next
    
24.     Next
    
25. End Sub

复制代码

hhzjxss

我把楼上的代码修改了一下，如下：

附件： 按省份拆分成多个工作表.rar (16.54 KB, 下载次数: 4)

2017-7-3 21:09 上传

点击文件名下载附件

1. 
   
2. Sub 拆分到省份表()
   
3.     Dim Sh As Worksheet
   
4.     Dim i&, r&, d
   
5.     Dim x$
   
6. 
   
7.     On Error Resume Next
   
8. 
   
9.     Set d = CreateObject("Scripting.Dictionary")
   
10.     For Each Sh In ThisWorkbook.Worksheets
    
11.         d(Sh.Name) = ""
    
12.     Next
    
13.     arr = [A1].CurrentRegion
    
14.     For i = 2 To UBound(arr)
    
15.         x = Left(arr(i, 2), 2)
    
16.         For Each Sh In Worksheets
    
17.             If Not d.exists(x) Then
    
18.                 ThisWorkbook.Worksheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
19.                 ActiveSheet.Name = x
    
20.                 d(x) = ""
    
21.                 r = Cells(1, 1).CurrentRegion.Rows.Count + 1
    
22.                 Sheets("总表").Range("A1:B1").Copy ActiveSheet.Range("A1")
    
23.                 Cells(r, 1) = arr(i, 1)
    
24.                 Cells(r, 2) = arr(i, 2)
    
25.             Else
    
26.                 Worksheets(x).Activate
    
27.                 Rows("2:65536").ClearContents
    
28.                 r = Cells(1, 1).CurrentRegion.Rows.Count + 1
    
29.                 Cells(r, 1) = arr(i, 1)
    
30.                 Cells(r, 2) = arr(i, 2)
    
31.             End If
    
32.             Cells.EntireColumn.AutoFit
    
33.             Exit For
    
34.         Next
    
35.     Next
    
36. End Sub

复制代码

laoau138

chart888 发表于 2017-7-3 16:19
这个你不会？
你确定？？？
以我对你别的代码的了解

你确定什么了

hhzjxss

laoau138 发表于 2017-7-3 21:20
你确定什么了

他是要你确定！哈哈！