|
|
楼主 |
发表于 2018-12-21 16:52
|
显示全部楼层
本帖最后由 LMY123 于 2018-12-22 09:19 编辑
1-12 A列拆分成文件夹_同时B列拆分成工作薄（字典法，ADO法）'http://club.excelhome.net/thread-1452244-1-1.html
Sub A列拆分成文件夹_同时B列拆分成工作薄_COPY_双字典() ''已入VBA代码宝库'
Dim fs As New FileSystemObject
路径 = ThisWorkbook.Path & "\"
Set 等待拆分表 = ThisWorkbook.Sheets(1)
Set 夹字典 = CreateObject("scripting.dictionary")
Set 薄字典 = CreateObject("scripting.dictionary")
源数组 = Range("a1").CurrentRegion
ReDim 结果数组(1 To UBound(源数组), 1 To UBound(源数组, 2))
For 行 = 2 To UBound(源数组)
If Not 夹字典.Exists(源数组(行, 1)) Then '新建文件夹
夹字典(源数组(行, 1)) = ""
If Not fs.FolderExists(路径 & 源数组(行, 1)) Then fs.CreateFolder (路径 & 源数组(行, 1))
End If
夹薄拆分列 = 源数组(行, 1) & "," & 源数组(行, 2)
薄字典(夹薄拆分列) = 薄字典(夹薄拆分列) & "," & 行
Next 行
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
For Each 薄字典关键字 In 薄字典.Keys
薄字典关键字拆分数组 = Split(薄字典关键字, ",")
y = Split(薄字典(薄字典关键字), ",")
For i = 1 To UBound(y)
For 列 = 1 To UBound(源数组, 2)
结果数组(i, 列) = 源数组(y(i), 列)
Next 列
Next i
等待拆分表.Copy
With ActiveWorkbook
.Sheets(1).UsedRange.Offset(1, 0).ClearContents
.Sheets(1).Range("a2").Resize(UBound(y), UBound(结果数组, 2)) = 结果数组
.SaveAs Filename:=路径 & 薄字典关键字拆分数组(0) & "\" & 薄字典关键字拆分数组(1) & ".xlsx" '另存为工作簿
.Close 0
End With
Next 薄字典关键字
Application.SheetsInNewWorkbook = 3
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub
Sub A列拆分成文件夹_同时B列拆分成工作薄_UNION_单字典() ''已入VBA代码宝库'
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Set 字典 = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
源行数 = .Cells(.Rows.Count, 1).End(xlUp).Row
源数组 = .Range("a1:d" & 源行数)
For 行 = 2 To UBound(源数组)
If Not 字典.Exists(源数组(行, 1)) Then
Set 字典(源数组(行, 1)) = CreateObject("scripting.dictionary")
End If
If Not 字典(源数组(行, 1)).Exists(源数组(行, 2)) Then
Set 字典(源数组(行, 1))(源数组(行, 2)) = .Range("a1:d1")
End If
Set 字典(源数组(行, 1))(源数组(行, 2)) = Union(字典(源数组(行, 1))(源数组(行, 2)), .Cells(行, 1).Resize(1, 4))
Next 行
End With
路径 = ThisWorkbook.Path & "\"
Application.SheetsInNewWorkbook = 1
For Each 夹关键字 In 字典.Keys
If Dir(路径 & 夹关键字, vbDirectory) = "" Then
MkDir 路径 & 夹关键字
End If
For Each 薄表关键字 In 字典(夹关键字).Keys
Set 新生薄 = Workbooks.Add
With 新生薄
With .Worksheets(1)
.Name = 薄表关键字
字典(夹关键字)(薄表关键字).Copy .Range("a1")
End With
.SaveAs Filename:=路径 & 夹关键字 & "\" & 薄表关键字
.Close False
End With
Next 薄表关键字
Next 夹关键字
Application.ScreenUpdating = True
End Sub
'http://club.excelhome.net/thread-1003488-2-1.html
Sub A列拆分成文件夹_同时B列拆分成工作薄_ADO法() ''已入VBA代码宝库'
夹数组 = Range("A1", [A1].End(2))
Set 连接 = CreateObject("Adodb.Connection")
连接.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Sql = "Select Distinct 乡办 From [Sheet1$] Where 乡办<>''"
夹记录数组 = 连接.Execute(Sql).getrows
Application.ScreenUpdating = False
For 夹行 = 0 To UBound(夹记录数组, 2)
MkDir ThisWorkbook.Path & "\" & 夹记录数组(0, 夹行)
Sql = "Select Distinct 村居 From [Sheet1$] Where 乡办='" & 夹记录数组(0, 夹行) & "'"
薄记录数组 = 连接.Execute(Sql).getrows
For 薄行 = 0 To UBound(薄记录数组, 2)
Set 新生薄 = Workbooks.Add
新生薄.Sheets(1).[A1].Resize(1, UBound(夹数组, 2)) = 夹数组
Sql = "Select * From [Sheet1$] Where 村居+乡办='" & 薄记录数组(0, 薄行) & 夹记录数组(0, 夹行) & "'"
新生薄.Sheets(1).[A2].CopyFromRecordset 连接.Execute(Sql)
新生薄.SaveAs ThisWorkbook.Path & "\" & 夹记录数组(0, 夹行) & "\" & 薄记录数组(0, 薄行) & ".xlsx"
新生薄.Close
Next
Next
Application.ScreenUpdating = True
连接.Close: Set 连接 = Nothing
End Sub
|
|
楼主: LMY123
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-12-21 19:59
