如何将一个工作簿按照第F列拆分为不同工作簿

jun_daye

请大神帮忙，如何将工作簿按照“创建机构”拆分成不同的工作簿并保存

donghui2363

Sub 拆分()
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
p = ThisWorkbook.Path & "\"
    Sql = "select distinct 创建机构 from [sheet1$]"
    arr = cnn.Execute(Sql).GetRows
    For j = 0 To UBound(arr, 2)
        s = arr(0, j)
        Sql = "select * into " & p & s & ".xls.[" & s & "] from [sheet1$] where 创建机构='" & s & "'"
        cnn.Execute (Sql)
    Next j
    cnn.Close
    Set cnn = Nothing
End Sub

donghui2363

Sub 拆分()
Dim wk As Workbook
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    arr = Sheet1.UsedRange
    crr = Sheet1.Range("a1:l1")
    For i = 2 To UBound(arr)
        d(arr(i, 6)) = ""
    Next i
    For Each s In d.keys
        ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
        k = 0
        For i = 2 To UBound(arr)
            If arr(i, 6) = s Then
                k = k + 1
                For j = 1 To UBound(arr, 2)
                    brr(k, j) = arr(i, j)
                Next j
            End If
        Next i
        Set wk = Workbooks.Add
        wk.Sheets(1).Name = s
        wk.Sheets(1).Range("a1:l1") = crr
        wk.Sheets(1).Range("a2").Resize(k, UBound(brr, 2)) = brr
        wk.Sheets(1).Cells.EntireColumn.AutoFit
        wk.SaveAs ThisWorkbook.Path & "\" & s & ".xlsx"
        wk.Close False
    Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

opel-wong

donghui2363 发表于 2020-8-10 15:14
Sub 拆分()
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0; ...

请教一下，为啥我用一楼的附件，二楼的代码，测试通不过呢？
如图：
     

donghui2363

opel-wong 发表于 2020-8-10 16:42
请教一下，为啥我用一楼的附件，二楼的代码，测试通不过呢？
如图：

提示什么啊？

xiangbaoan

donghui2363 发表于 2020-8-11 08:38
提示什么啊？

可能是没解压到磁盘就运行