|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
原帖由 sl8831 于 2011-3-15 16:40 发表 
刚刚又筛了一次 还是不行 都是好几mb 真正的数据其实就几百kb
请您修改一下的代码
Sub Macro1()
Dim cnn As Object, rs As Object, wb As Workbook, wb1 As Workbook
Dim SQL$, arr, i%, desk$, File ...
Sub Macro1()
Dim cnn As Object, rs As Object, wb As Workbook, wb1 As Workbook
Dim SQL$, arr, i%, desk$, Filename, sh As Worksheet, d As Object, av%, str1$, s$, pinyin$
Dim hp As HZ2PY
av = Application.Version
If av <= 11 Then
Filename = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls),*.xls", Title:="请选择文件")
Else
Filename = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="请选择文件")
End If
If TypeName(Filename) = "Boolean" Then Exit Sub
If Filename = ThisWorkbook.FullName Then
MsgBox "不能选择本文件！请重新选择"
Exit Sub
End If
arr = Split(Filename, ".")
If arr(UBound(arr)) = "xls" Then str1 = ".xls" Else str1 = ".xlsx"
Set hp = New HZ2PY
hp.InitialOnly = False
hp.OnlyOneChar = True
arr = Array("河南郑州", "河南洛阳", "河南新乡", "福建福州", "福建厦门", "福建泉州", "安徽合肥")
Set d = CreateObject("scripting.dictionary")
If Val(Right(Application.OperatingSystem, 4)) >= 6 Then s = "\Desktop\" Else s = "\桌面\"
desk = Environ("USERPROFILE") & s
Set cnn = CreateObject("ADODB.Connection")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = Workbooks.Open(Filename)
If av <= 11 Then
cnn.Open "provider=Microsoft.Jet.OLEDB.4.0;extended properties=excel 8.0;data source=" & Filename
Else
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Filename
End If
For Each sh In wb.Sheets
If Len(SQL) Then SQL = SQL & " union all "
SQL = SQL & "Select distinct 地区 From [" & sh.Name & "$]"
Next
Set rs = CreateObject("ADODB.Recordset")
rs.Open SQL, cnn, 1, 3
For i = 1 To rs.RecordCount
d(rs.Fields(0).Value) = ""
rs.MoveNext
Next
For i = 0 To UBound(arr)
If d.Exists(arr(i)) Then
s = arr(i)
pinyin = hp.AdjustPhoneticNotation(hp.GetPinYin(s), pnNoNotation)
wb.SaveCopyAs desk & pinyin & str1
Set wb1 = Workbooks.Open(desk & pinyin & str1)
For Each sh In wb1.Sheets
SQL = "Select * From [" & sh.Name & "$] Where 地区='" & arr(i) & "'"
Set rs = CreateObject("ADODB.Recordset")
rs.Open SQL, cnn, 1, 3
If rs.RecordCount > 0 Then
With sh
.Activate
.[a1].Select
lr = .[a1].CurrentRegion.Rows.Count
' .UsedRange.Offset(1).EntireRow.Delete
.Rows("2:" & Cells.Rows.Count).Delete '从第二行到最后以行全部删除
.[A2].CopyFromRecordset rs
End With
ActiveWindow.SmallScroll Down:=lr * (-1)
Else
sh.Delete
End If
Next
wb1.Close True
End If
Next
wb.Close False
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok"
End Sub |
|
楼主: sl8831
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-3-15 16:33
楼主