整理附件，重新发帖求助，求加快分割文件代码运行速度

abc123281

Sub 按地区拆分sql()
t = Timer
Dim ws As Worksheet
Dim wb As Workbook
Dim path$, i&, sql$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set wb = ThisWorkbook
path = wb.FullName
With Worksheets("操作表")
  r = .[e65536].End(xlUp).Row
  arr = .Range("e1:f" & r)
  For i = 2 To UBound(arr)
    d(arr(i, 1)) = i
  Next
End With
For Each ws In Worksheets
If InStr(ws.Name, "data") <> 0 Then
   arr = ws.UsedRange
   For i = 2 To UBound(arr)
      If d.exists(arr(i, 1)) Then
        d1(arr(i, 1)) = i
      End If
   Next
End If
Next
Application.SheetsInNewWorkbook = 1
For Each aa In d1.keys
  With Workbooks.Add
    .Worksheets(1).Name = aa
     For Each ws In wb.Worksheets
       If InStr(ws.Name, "data") <> 0 Then
         k = k + 1
         If k = 1 Then
           conn.Open "provider=microsoft.ace.oledb.12.0;extended properties='Excel 12.0;hdr=yes';data source=" & path
         End If
         mn = ws.Name
         sql = "select * from [" & mn & "$] where 地区 = '" & aa & "'"
         Set rst = conn.Execute(sql)
         With .Worksheets(aa)
           r = .Cells(.Rows.Count, 1).End(xlUp).Row
           If r = 1 Then
             For j = 0 To rst.Fields.Count - 1
              .Cells(1, j + 1) = rst.Fields(j).Name
             Next
           End If
          .Range("A" & r + 1).CopyFromRecordset rst
         End With
        End If
      Next
     .SaveAs Filename:=wb.path & "\拆分结果\" & aa
     .Close
  End With
Next
rst.Close
conn.Close
Set conn = Nothing
Set rst = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "数据拆分完毕！" & Chr(10) & "共用时" & Format(Timer - t, "0.0000") & "秒", 64
End Sub

abc123281

系统审核太慢   代码发重了  两个代码一样的