如何拆分成多个独立工作薄

zhongtaizu43

求各位帮忙         这个表格里有两个附表“应收”、“应付”，  “应收”的客户名称和“应付”的供货商名称有相同的公司名称（例如：佛山医药有限公司），只是有些名称后面多了".."，现在我想把对应相同的名称拆分为多个独立的工作薄，（例如：佛山医药有限公司.xlsx,里面两个附表分别只有佛山医药的应收和应付数据），也就是说结果是3个独立的工作簿（广东医药集团、佛山医药、湛江医药）  该如何编写代码，望回复，谢谢

约定的童话

应收跟应付行数不一致啊，公司名称按照哪个表来建立？

zhongtaizu43

约定的童话 发表于 2019-11-8 09:22
应收跟应付行数不一致啊，公司名称按照哪个表来建立？

按照哪个表都可以，名称为：湛江医药有限公司.XLSX        佛山医药有限公司.XLSX   广东医药集团总部.XLSX

约定的童话

zhongtaizu43 发表于 2019-11-8 12:01
按照哪个表都可以，名称为：湛江医药有限公司.XLSX        佛山医药有限公司.XLSX   广东医药集团总部.XL ...

有多的有少的，你这个肯定要取两个都有的吧？

zhongtaizu43

约定的童话 发表于 2019-11-8 13:59
有多的有少的，你这个肯定要取两个都有的吧？

是的，只要分拆成3个独立的工作薄，每个工作薄都有应收应付两个附表就可以了

zhongtaizu43

大家有没有什么办法？

xiangbaoan

Option Explicit
Sub test()
    Dim Cn As Object, Sq$, ar, br(1 To 2), i%, j%
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set Cn = CreateObject("ADODB.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Sq = "SELECT DISTINCT Replace(供货商名称,'.','') FROM [应付$]"
    ar = Cn.Execute(Sq).GetRows
    br(1) = "SELECT * FROM [应收$] WHERE Replace(客户名称,'.','')='"
    br(2) = "SELECT * FROM [应付$] WHERE Replace(供货商名称,'.','')='"
    For j = 0 To UBound(ar, 2)
        If Not IsNull(ar(0, j)) Then
            Sheets(Array("应收", "应付")).Copy
            With ActiveWorkbook
                For i = 1 To 2
                    .Sheets(i).UsedRange.Offset(1).ClearContents
                    Sq = br(i) & ar(0, j) & "'"
                    .Sheets(i).[a2].CopyFromRecordset Cn.Execute(Sq)
                Next
                .SaveAs ThisWorkbook.Path & "\" & ar(0, j), 51
                .Close
            End With
        End If
    Next
    Cn.Close
    Set Cn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "ok", 64
End Sub

xiangbaoan

………………