AW: @Sepp/a.alle a.Helfer Diagramm Daten extern
08.03.2009 20:14:17
Michaela
Hallo Sepp,
Oh ja, Bitte!
Bei meiner Recherche im Net zum Thema "Daten aus geschlossener Mappe" bin auf einen Code gestossen, der zwar schon in dieser Richtung geht, aber mein Level einfach übersteigt.
Vielen Dank
LG
Michaela
Option Explicit
Private Const mc_MsgTitle As String = "" & _
"Daten aus einer geschlossenen Arbeitsmappe einlesen (ADO)"
Public Sub Start_GetDataFromWkb_ADO()
Dim strDBName As String 'Dateiname der Arbeitsmappe
Dim strSource As String 'Tabellenname/Quellbereich der Arbeitsmappe
Dim strSQL As String 'SQL-Anweisung
Dim avarDataXL() As Variant 'Datenfeld mit Daten aus Quellbereich
Dim optXLCalcMode As Long 'Option Berechnungsart
Dim wksDest As Worksheet 'Ziel-Tabellenblatt
Dim nColDest As Integer 'Ziel-Spalte im Ziel-Tabellenblatt
Dim nRowDest As Long 'Ziel-Zeile im Ziel-Tabellenblatt
'Name der Arbeitsmappe inkl. Pfad
strDBName = ThisWorkbook.Path & "\TestDateien\Februar09.xls" ' False übergeben !!!!
If GetDataFromWkb_ADO(strDBName, strSQL, True, avarDataXL()) Then
'Einstellungen speichern/zuweisen
With Application
'Berechnungsart speichern
optXLCalcMode = .Calculation
.Calculation = xlManual
'Das Ausführen von Ereignissen deaktivieren
.EnableEvents = False
End With
'Objektverweis auf Ziel-Tabellenblatt setzen
Set wksDest = ActiveWorkbook.Worksheets(1)
'Ziel-Spalte und -Zeile zuweisen (!!! Anpassen !!!)
nColDest = 1
'nRowDest = 10
'Fehlerbehandlung
On Error Resume Next
'Nächste freie Zeile in Ziel-Tabellenblatt ermitteln
With wksDest
If Application.WorksheetFunction.CountA(.Cells) > 0 Then
nRowDest = .Cells.Find(What:="*", After:=.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
'o d e r Nächste freie Zeile in Ziel-Spalte ermitteln
'nRowDest = .Cells(.Rows.Count, nColDest).End(xlUp).Row + 1
Else
nRowDest = 2
End If
'Daten ins Ziel-Tabellenblatt schreiben
Err.Clear
.Cells(nRowDest, nColDest).Resize(UBound(avarDataXL, 1) + 1, _
UBound(avarDataXL, 2) + 1).Value = avarDataXL
If Err.Number = 0 Then
'Spaltenbreiten anpassen
.UsedRange.Columns.AutoFit
MsgBox "Die Daten aus dem Quellbereich '" & strSource & _
"' wurden eingelesen!", vbInformation, mc_MsgTitle
Else
MsgBox "Fehler " & Err.Number & vbCrLf & _
Err.Description, vbCritical, mc_MsgTitle
End If
End With
'Datenfeld löschen
Erase avarDataXL
'Objektverweise (Speicher) freigeben
Set wksDest = Nothing
'Einstellungen zurücksetzen
With Application
'Das Ausführen von Ereignissen wieder aktivieren
.EnableEvents = True
'Berechnungsart wieder zurücksetzen
.Calculation = optXLCalcMode
End With
End If
'Fehlerbehandlung zurücksetzen
On Error GoTo 0
End Sub
Private Function GetDataFromWkb_ADO(ByVal strDBName As String, _
ByVal strSQL As String, ByVal fColHDR As Boolean, _
ByRef avarDataXL() As Variant) As Boolean
'Argumente:
' strDBName Dateiname der Arbeitsmappe
' strSQL Quellbereich und ggf. weitere Kriterien/Bedingungen
' fColHDR True/False - Spaltenüberschriften ?
' avarDataXL() Datenfeld mit den Daten aus dem Quellbereich
'Rückgabe der Funktion:
' True, wenn keine Fehler aufgetreten sind und
' im Datenfeld avarDataXL() die Daten aus dem Quellbereich
Dim cnnADO As ADODB.Connection
Dim rstADO As ADODB.Recordset
Dim strExtProps As String 'Verbindungs-Informationen
Dim avarDataRS As Variant 'Datenfeld mit den Daten
Dim nFieldsCnt As Long 'Anzahl Felder (Spalten)
Dim nRecordsCnt As Long 'Anzahl Datensätze (Zeilen)
Dim nFld As Long 'Zähler
Dim nRec As Long
Dim blnData As Boolean 'True, wenn tatsächlich Daten vorhanden sind
'Verbindungs-Informationen ("Extended Properties") zuweisen
strExtProps = "Excel 8.0;"
'Wenn in den Quelltabellenblättern keine Spaltenüberschriften
'vorhanden sind...
If Not fColHDR Then
strExtProps = strExtProps & "HDR=No;"
End If
'Fehlerbehandlung aktivieren
On Error GoTo err_GetValues
'Datenbank öffnen
Set cnnADO = New ADODB.Connection
With cnnADO
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties").Value = strExtProps
.Open strDBName
End With
'RecordSet-Object erstellen
Set rstADO = New ADODB.Recordset
With rstADO
.ActiveConnection = cnnADO
.CursorLocation = adUseClient
.Source = strSQL
.Open
End With
'Wenn Datensätze vorhanden sind...
If Not (rstADO.EOF Or rstADO.BOF) Then
'Daten -> zweidimensionales Datenfeld
avarDataRS = rstADO.GetRows()
'GetRows-Methode
' Datensätze aus dem Recordset-Objekt kopieren.
' GetRows gibt ein zweidimensionales Feld zurück. Der erste Index
' identifiziert das Feld und der zweite die Zeilennummer.
If IsArray(avarDataRS) Then
'Anzahl Felder und Datensätze ermitteln
nFieldsCnt = UBound(avarDataRS, 1)
nRecordsCnt = UBound(avarDataRS, 2)
'Datenfeld dimensionieren
ReDim avarDataXL(nRecordsCnt, nFieldsCnt)
'Datenfeld transponieren
For nFld = 0 To nFieldsCnt
For nRec = 0 To nRecordsCnt
If Not IsNull(avarDataRS(nFld, nRec)) Then
'Datum gesondert behandeln
' (z.B. in Excel 97 werden die Datumswerte
' nicht "richtig" erkannt
If IsDate(avarDataRS(nFld, nRec)) Then
avarDataXL(nRec, nFld) = _
Format$(avarDataRS(nFld, nRec), "yyyy-mm-dd")
Else
avarDataXL(nRec, nFld) = avarDataRS(nFld, nRec)
End If
blnData = True 'True, wenn tatsächlich Daten vorhanden sind
'Wird als Quellbereich ein Bereich angegeben, das keine Daten enthält, _
so
'werden unter Umständen trotzdem Datensätze zurückgegeben. Dies ist z. _
B.
'dann der Fall, wenn im Quellbereich lediglich der Zellinhalt gelö _
scht
'wurde (Entf), und nicht die Zeile selbst (Zellen löschen.../Ganze _
zeile).
End If
Next 'nRec
Next 'nFld
Erase avarDataRS 'Datenfeld löschen
'Rückgabe der Funktion
If blnData Then 'True, wenn Daten vorhanden sind
GetDataFromWkb_ADO = True
Else
MsgBox "Der Quellbereich enthält keine Daten!", _
vbInformation, mc_MsgTitle
End If
End If
Else
MsgBox "Keine entsprechenden Datensätze gefunden!", _
vbInformation, mc_MsgTitle
End If
exit_Func:
'Fehlerbehandlung
On Error Resume Next
'RecordSet/Datenbank schließen,
'Objektverweise (Speicher) freigeben
rstADO.Close
Set rstADO = Nothing
cnnADO.Close
Set cnnADO = Nothing
'Fehlerbehandlung zurücksetzen
On Error GoTo 0
Exit Function
err_GetValues:
MsgBox "Fehler " & Err.Number & vbCrLf & Err.Description, _
vbOKOnly + vbCritical, mc_MsgTitle
Resume exit_Func
End Function