【求助】按条件拆分一个EXCEL表格

sinian591

各位大拿，我想把附件中清单，按照第一列机构代码拆分成多个excel文件。
恳请大拿帮忙实现，谢谢！

凌空一羽

Sub 生成()
Dim wb As Workbook, i As Integer
Set d = CreateObject("Scripting.Dictionary")
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
    d(arr(i, 1)) = ""
Next
For i = 0 To d.Count - 1
Set wb = Workbooks.Add
    wb.SaveAs ThisWorkbook.Path & "\" & d.keys()(i) & ".xls"
wb.Close
Next
Set wb = Nothing
Set d = Nothing
End Sub

sinian591

凌空一羽 发表于 2017-2-8 12:22
Sub 生成()
Dim wb As Workbook, i As Integer
Set d = CreateObject("Scripting.Dictionary")

你好，运行后得到的是名称为各个机构代码的空EXCEL表格，并不能实现原表拆分呀。
仍然感谢！

mjzxlmg

1. Sub 生成()
   
2.     Application.ScreenUpdating = False
   
3.     Dim d, wb As Workbook, arr, i As Integer, j As Integer, key, record, totalrow&, fso
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     arr = Range("a1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         If d.exists(arr(i, 1)) = False Then
   
8.             d(arr(i, 1)) = i
   
9.         Else
   
10.             d(arr(i, 1)) = d(arr(i, 1)) & "!" & i
    
11.         End If
    
12.     Next
    
13.     Set fso = CreateObject("Scripting.FileSystemObject")
    
14.     If fso.FolderExists(ThisWorkbook.Path & "\机构代码") = True Then fso.GetFolder(ThisWorkbook.Path & "\机构代码").Delete
    
15.     fso.CreateFolder ThisWorkbook.Path & "\机构代码"
    
16.     For Each key In d.keys
    
17.         record = Split(d(key), "!")
    
18.         totalrow = UBound(record)
    
19.         ReDim result(1 To totalrow + 2, 1 To UBound(arr, 2))
    
20.         For i = 0 To totalrow
    
21.             For j = 1 To UBound(arr, 2)
    
22.                 If i = 0 Then result(1, j) = arr(1, j)
    
23.                 result(i + 2, j) = arr(record(i), j)
    
24.             Next
    
25.         Next
    
26.         Set wb = Workbooks.Add
    
27.         With wb.Worksheets(1)
    
28.             .Cells.NumberFormatLocal = "@"
    
29.             .Cells(1, 1).Resize(totalrow + 2, UBound(arr, 2)).Value = result
    
30.         End With
    
31.         wb.SaveAs ThisWorkbook.Path & "\机构代码" & key
    
32.         wb.Close False
    
33.      Next
    
34.      Application.ScreenUpdating = True
    
35.     Set wb = Nothing
    
36.     Set d = Nothing
    
37. End Sub

复制代码

sinian591

mjzxlmg 发表于 2017-2-8 14:11

谢谢大神，成功了。

lsc900707

附件在哪里？ 怎么没看到？

zhouyou8810

mjzxlmg 发表于 2017-2-8 14:11

如果一个工作簿里有两个sheet表代码怎么写？

zhouyou8810

mjzxlmg 发表于 2017-2-8 14:11

  000000000000

zhouyou8810

有两个工作表要这样匹量生成怎么办，这个工作簿里只是一个工作表。

lsc900707

zhouyou8810 发表于 2018-9-1 00:34
有两个工作表要这样匹量生成怎么办，这个工作簿里只是一个工作表。

上传附件，可以多表同时拆分的。