|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 ljch1327 于 2018-10-20 14:34 编辑
2003版本能否使用?或者請指點一下怎么修改﹖下面的代碼錯誤提示﹕找不到可安裝的ISAMSub Query()
Dim strFile() As String '陣列變數，用於存儲資料原始檔案
Dim lSource As Long '確認資料原始檔案的最後一行的行號
Dim sql As String '查詢語句
Dim strField As String, Value '條件參數的欄位名和值
Dim strSourceFileName As String '數據原始檔案
Dim iCriteria As Integer '確認查詢條件的個數
Dim strCriteria As String '查詢條件字串
Dim strFlag As String, strOp As String 'sql語句中的識別字
Dim RowOfHeader As Long '查詢結果起始行
Dim lEndRow As Long '臨時存儲最後一行
t = Timer '定義程式開始的時間
RowOfHeader = 5 '查詢結果的標題所在的行號
Application.ScreenUpdating = False
On Error GoTo ErrHandler
shDataSource.Activate
lSource = shDataSource.Range("A65535").End(xlUp).Row
'判斷是否有資料檔案
If lSource = 1 Then
MsgBox "Please select at least one file as data source!", vbOKOnly + vbExclamation, "Message"
Exit Sub
'判斷資料檔案列表是否連續
ElseIf lSource > Application.WorksheetFunction.CountA(ActiveSheet.Columns("A:A")) Then
MsgBox "Please make sure the data source list is consistent!", vbOKOnly + vbExclamation, "Message"
Exit Sub
End If
ReDim strFile(1 To lSource - 1, 1 To 2) '資料檔案列表
For j = 1 To lSource - 1
strFile(j, 1) = ThisWorkbook.ActiveSheet.Cells(j + 1, 1)
strFile(j, 2) = ThisWorkbook.ActiveSheet.Cells(j + 1, 2)
Next
ShQuery.Activate
iCriteria = ActiveSheet.[IV1].End(xlToLeft).Column '確認最後一個條件的列號
If iCriteria = 1 Then
strCriteria = ""
Else
If iCriteria > Application.WorksheetFunction.CountA(ActiveSheet.Rows("1:1")) Then
MsgBox "Please make sure the criteria range is consistent!", vbOKOnly + vbExclamation, "Message"
Exit Sub
End If
strCriteria = " Where "
For i = 2 To iCriteria
strField = ActiveSheet.Cells(1, i)
Value = ActiveSheet.Cells(2, i)
If IsDate(ActiveSheet.Cells(2, i)) Then
strFlag = "#"
strOp = "="
ElseIf IsNumeric(ActiveSheet.Cells(2, i)) Then
strFlag = ""
strOp = "="
ElseIf Application.WorksheetFunction.IsText(ActiveSheet.Cells(2, i)) Then
If Left(Value, 1) = ">" Or Left(Value, 1) = "=" Or Left(Value, 1) = "<" Then
strFlag = ""
strOp = ""
ElseIf InStr(Value, "*") + InStr(Value, "?") > 0 Then
strFlag = "'"
strOp = " like "
Value = Replace(Replace(Value, "*", "%"), "?", "_")
Else
strFlag = "'"
strOp = "="
End If
End If
strCriteria = strCriteria & "[" & strField & "]" & strOp & strFlag & Value & strFlag & " and "
Next
strCriteria = Left(strCriteria, Len(strCriteria) - 5)
End If
Set cnn = CreateObject("adodb.connection")
'cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no;imex=1';Data Source=" & strFile(1, 1)
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source=" & strFile(1, 1)
sql = "select top 1 'Source',* from [" & strFile(1, 2) & "$]"
ActiveSheet.Range("A" & RowOfHeader & ":iv65535").ClearContents
'寫標題行
ActiveSheet.Range("A" & RowOfHeader).CopyFromRecordset cnn.Execute(sql)
cnn.Close
'cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes;imex=1';Data Source=" & strFile(1, 1)'2007 until now
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source=" & strFile(1, 1) '2003
strSourceFileName = Mid(strFile(1, 1), InStrRev(strFile(1, 1), "\") + 1, Len(strFile(1, 1)) - InStrRev(strFile(1, 1), "\"))
strSourceFileName = Left(strSourceFileName, InStr(strSourceFileName, ".") - 1)
strSourceFileName = "[" & strSourceFileName & "]" & strFile(1, 2)
Application.StatusBar = "正在讀取資料，請稍後..."
sql = "select '" & strSourceFileName & "' as Source,* from [" & strFile(1, 2) & "$]" & strCriteria
If lSource = 2 Then
lEndRow = ActiveSheet.Range("A65535").End(xlUp).Row
ActiveSheet.Range("A" & lEndRow + 1).CopyFromRecordset cnn.Execute(sql)
cnn.Close
Else
For k = 2 To lSource - 1
strSourceFileName = Mid(strFile(k, 1), InStrRev(strFile(k, 1), "\") + 1, Len(strFile(k, 1)) - InStrRev(strFile(k, 1), "\"))
strSourceFileName = Left(strSourceFileName, InStr(strSourceFileName, ".") - 1)
strSourceFileName = "[" & strSourceFileName & "]" & strFile(k, 2)
sql = sql & " union all select '" & strSourceFileName & "' as Source, * from [Excel 12.0;Database=" & strFile(k, 1) & "].[" & strFile(k, 2) & "$]"
'如果是EXCEL 12.0;錯誤提示﹕找不到可安裝的ISAM
If (k Mod 49 = 0) Or (k = lSource - 1) Then
sql = "select * from (" & sql & ")" & strCriteria
lEndRow = ActiveSheet.Range("A65535").End(xlUp).Row
ActiveSheet.Range("A" & lEndRow + 1).CopyFromRecordset cnn.Execute(sql)
cnn.Close
If k < lSource - 1 Then
'cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes;imex=1';Data Source=" & strFile(k + 1, 1) '2007 until now
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source=" & strFile(k + 1, 1) '2003
strSourceFileName = Mid(strFile(k + 1, 1), InStrRev(strFile(k + 1, 1), "\") + 1, Len(strFile(k + 1, 1)) - InStrRev(strFile(k + 1, 1), "\"))
strSourceFileName = Left(strSourceFileName, InStr(strSourceFileName, ".") - 1)
strSourceFileName = "[" & strSourceFileName & "]" & strFile(k + 1, 2)
sql = "select '" & strSourceFileName & "' as Source,* from [" & strFile(k + 1, 2) & "$]"
k = k + 1
End If
End If
Next
End If
Application.StatusBar = ""
ActiveSheet.Cells(RowOfHeader + 1, 1).Select
ActiveWindow.FreezePanes = True
ActiveSheet.Rows(RowOfHeader & ":" & RowOfHeader).Select
Selection.AutoFilter
ActiveSheet.Cells(RowOfHeader + 1, 1).Select
Application.ScreenUpdating = True
tLen = Round(Timer - t, 0)
MsgBox "已完成查詢，共查詢 " & lSource - 1 & " 個資料表，共讀取 " & ActiveSheet.Range("A65535").End(xlUp).Row - RowOfHeader & " 條記錄。" & vbCrLf & "程式共運行 " & IIf(tLen > 60, Int(tLen / 60) & "分" & IIf(tLen Mod 60 > 0, tLen Mod 60 & "秒。", ""), tLen & "秒。"), vbOKOnly + vbInformation, "Message"
'& vbCrLf & "程式共運行 " & IIf(tLen > 60, Int(tLen / 60) & "分" & IIf(tLen Mod 60 > 0, tLen Mod 60 & "秒。", ""), tLen & "秒。")
ErrHandler:
If Err.Number <> 0 Then
' MsgBox Err.Number
MsgBox "發生錯誤！" & vbCrLf & "錯誤描述：" & Err.Description, vbOKOnly + vbCritical, "Error"
Err.Clear
Exit Sub
End If
End Sub
|
|
楼主: Will.li
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-10-20 08:59
