一个总表根据条件拆分为多个分表并在同一个工作薄。论坛之前发布的代码总出现3706错误

shmihy

各位大神，求助拆分工作表。如图片中所列数据，想根据样地编号拆分成不同的表并在同一个工作薄中。之前论坛上搜到相应代码，但运行时总是出现3706错误，不知为何？

shmihy

Sub CFGZB()
    Dim myRange As Variant
    Dim myArray
    Dim titleRange As Range
    Dim title As String
    Dim columnNum As Integer
    myRange = Application.InputBox(prompt:="", Type:=8)
    myArray = WorksheetFunction.Transpose(myRange)
    Set titleRange = Application.InputBox(prompt:="", Type:=8)
    title = titleRange.Value
    columnNum = titleRange.Column
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i&, Myr&, Arr, num&
    Dim d, k
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> "数据源" Then
            Sheets(i).Delete
        End If
    Next i
    Set d = CreateObject("Scripting.Dictionary")
    Myr = Worksheets("数据源").UsedRange.Rows.Count
    Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = ""
    Next
    k = d.keys
    For i = 0 To UBound(k) - 1
        Set conn = CreateObject("adodb.connection")
        conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
        Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"
        Dim Nowbook As Workbook
        Set Nowbook = Workbooks.Add
        With Nowbook
            With .Sheets(1).Name = k(i)
                For num = 1 To UBound(myArray)
                    Cells(1, num) = myArray(num, 1)
                Next num
                Range("A2").CopyFromRecordset conn.Execute(Sql)
            End With
        End With
        ThisWorkbook.Activate
        Sheets(1).Cells.Select
        Selection.Copy
        Workbooks(Nowbook.Name).Activate
        ActiveSheet.Cells.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                               SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        Nowbook.SaveAs ThisWorkbook.Path & "\" & k(i)
        Nowbook.Close True
        Set Nowbook = Nothing
    Next i
    conn.Close
    Set conn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

shmihy

这是之前搜到的代码，但总是出错。急求答案！电脑小白痴，连换行都不知道怎么换。汗 好尴尬 好晕汗 好尴尬 好晕跪求，急求答案！毕业论文撰写中，卡住了，进行不下去了，想哭笑哭了  好担心

shmihy

Sub CFGZB()
    Dim myRange As Variant
    Dim myArray
    Dim titleRange As Range
    Dim title As String
    Dim columnNum As Integer
    myRange = Application.InputBox(prompt:="", Type:=8)
    myArray = WorksheetFunction.Transpose(myRange)
    Set titleRange = Application.InputBox(prompt:="", Type:=8)
    title = titleRange.Value
    columnNum = titleRange.Column
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i&, Myr&, Arr, num&
    Dim d, k
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> "数据源" Then
            Sheets(i).Delete
        End If
    Next i
    Set d = CreateObject("Scripting.Dictionary")
    Myr = Worksheets("数据源").UsedRange.Rows.Count
    Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = ""
    Next
    k = d.keys
    For i = 0 To UBound(k) - 1
        Set conn = CreateObject("adodb.connection")
        conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
        Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"
        Dim Nowbook As Workbook
        Set Nowbook = Workbooks.Add
        With Nowbook
            With .Sheets(1).Name = k(i)
                For num = 1 To UBound(myArray)
                    Cells(1, num) = myArray(num, 1)
                Next num
                Range("A2").CopyFromRecordset conn.Execute(Sql)
            End With
        End With
        ThisWorkbook.Activate
        Sheets(1).Cells.Select
        Selection.Copy
        Workbooks(Nowbook.Name).Activate
        ActiveSheet.Cells.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                               SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        Nowbook.SaveAs ThisWorkbook.Path & "\" & k(i)
        Nowbook.Close True
        Set Nowbook = Nothing
    Next i
    conn.Close
    Set conn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub这是之前搜到的代码。红色字体部分总是出错，