按大区将数据拆分为4个工作薄

LMY123

多表同时拆分成工作薄

jiminyanyan

把题目看懂就10几帖了。。。。

不知道为什么

jiminyanyan 发表于 2018-7-2 21:15
把题目看懂就10几帖了。。。。

哈哈，今天老师的这句话最幽默了

duquancai

不知道为什么 发表于 2018-7-2 21:19
哈哈，今天老师的这句话最幽默了

SQL分类拆分     OK！

duquancai

请测试》》》》》》》》》》》》》》》》》》》
Sub main()
    Dim dq, sh, sql$, conn As Object, i&, j&
    dq = Array("华南", "华北", "华东", "华中")
    sh = Array("汇总表", "基本信息", "表1", "表2", "表3", "表4")
    Set conn = CreateObject("adodb.connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=" & ThisWorkbook.FullName
    Application.ScreenUpdating = False
    For i = 0 To UBound(dq)
        Sheets(sh).Copy
        For j = 1 To UBound(sh) + 1
            Select Case j
            Case Is = 1
                With ActiveWorkbook.Sheets(j)
                    .[a4:bm5000].ClearContents
                    sql = "select * from [" & sh(j - 1) & "$a4:bm] where f10='" & dq(i) & "'"
                    .[a4].CopyFromRecordset conn.Execute(sql)
                End With
            Case Is = 2, 3, 4
                With ActiveWorkbook.Sheets(j)
                    .[a2:bm5000].ClearContents
                    sql = "select * from [" & sh(j - 1) & "$a2:bm] where f1='" & dq(i) & "'"
                    .[a2].CopyFromRecordset conn.Execute(sql)
                End With
            Case Is = 5, 6
                With ActiveWorkbook.Sheets(j)
                    .[a3:bm5000].ClearContents
                    sql = "select * from [" & sh(j - 1) & "$a3:bm] where f1='" & dq(i) & "'"
                    .[a3].CopyFromRecordset conn.Execute(sql)
                End With
            End Select
        Next
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & dq(i) & ".xlsx"
        ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = True
    MsgBox "ok!"
End Sub

baobaoai110

duquancai 发表于 2018-7-2 22:40
请测试》》》》》》》》》》》》》》》》》》》
Sub main()
    Dim dq, sh, sql$, conn As Object, i&,  ...

厉害了，目前测试为完美。

baobaoai110

duquancai 发表于 2018-7-2 22:40
请测试》》》》》》》》》》》》》》》》》》》
Sub main()
    Dim dq, sh, sql$, conn As Object, i&,  ...

大师，总表里有公式，拆分后的工作薄能否保留公式？