AW: nähere Erkläung vielleicht ?
29.04.2006 07:17:24
Jürgen
Hallo Solaiman,
dbSheet= Angabe des Tabellenblatt, dbRange= Bereichsangabe
Sub importIt()
GetSheet "H:\Sicher\test.xls", "Ausw.-Monat 4", _
"A1:IV6500", Sheets("Tabelle2").Range("A1"), True ' True = Überschriften Mit-Ohne
End Sub
Public
Sub GetSheet(dbfile As Variant, dbSheet As String, _
dbRange As String, newRange As Range, hdRow As Boolean)
Dim rs As ADODB.Recordset, cnt$, xSQL$, i&
If Range(dbRange).Rows.Count = 1 Then
cnt = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & dbfile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
cnt = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & dbfile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
End If
xSQL = "SELECT * FROM [" & dbSheet$ & "$" & dbRange$ & "];"
On Error GoTo Mistake
Set rs = New ADODB.Recordset
rs.Open xSQL, cnt, adOpenForwardOnly, _
adLockReadOnly, adCmdText
If Not rs.EOF Then
If Range(dbRange).Rows.Count = 1 Then
newRange.Cells(1, 1).CopyFromRecordset rs
Else
If hdRow Then
For i = 0 To rs.Fields.Count - 1
newRange.Cells(1, 1 + i).Value = _
rs.Fields(i).Name
Next i
newRange.Cells(2, 1).CopyFromRecordset rs
Else
newRange.Cells(1, 1).CopyFromRecordset rs
End If
End If
Else
MsgBox "No records returned from : " & dbfile, vbCritical
End If
rs.Close
Set rs = Nothing
Exit Sub
Mistake:
MsgBox "The file name, Sheet name or Range is invalid of : " & dbfile, _
vbExclamation, "Error"
On Error GoTo 0
End
Sub
Gruss
Jürgen