|
写了一个按地区拆分的 仅供测试参考 废话不多说 上代码
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
|
|