Werte aus geschlossener Datei
28.01.2009 20:57:00
Schmausi
ich habe im Forum verschiedene Vatianten gefunden um einen Werte aus einer geschlossenen Datei auszulesen.
Dies habe ich mir versucht um zuschreiben.
Dabei klappt es wunderbar, das ich aus mehreren bestimmten Dateien aus den Tabellenblättern 1 jeweisls aus Zelle "I39" in der neuen Tabelle die Werte zusammenfassen kann.
Im Beispiel steht in jeder aus zulesenden Tabelle in "I39" der Wert 40.
Das Ergebnis wird wie gewünscht aus 6 Tabellen 240.
Option Explicit
'Pfad und Name des Tabellenblattes anpassen
Const strPfad = "D:\meine Dateien\Eigene "
Const strTabelle = "Teil1"
' Dim strPfad As String
' Dim strTabelle As String
Dim strDateiName() As String
Dim strBezug As String
Dim intDateiAnzahl As Integer
Dim intZeile As Integer
Dim n As Integer
Dim datWerte() As Variant
Sub Abfrage_starten()
Call Dateien_auslesen
For n = 1 To intDateiAnzahl
' procExternerBereich
meine_test
Next n
End Sub
Sub Dateien_auslesen()
Dim objFileSearch As Object
Set objFileSearch = Application.FileSearch
With objFileSearch
.LookIn = strPfad
.Filename = "FI*.xls"
.SearchSubFolders = False 'bei True werden alle Unterverzeichnisse mit durchsucht
If .Execute > 0 Then
intDateiAnzahl = .FoundFiles.Count
ReDim strDateiName(1 To intDateiAnzahl)
ReDim datWerte(1 To 3, 1 To intDateiAnzahl)
For n = 1 To intDateiAnzahl
strDateiName(n) = Right(.FoundFiles(n), Len(.FoundFiles(n)) - Len(strPfad) - 1) ' _
nur Dateiname
' MsgBox strDateiName(n)
Next
End If
End With
Set objFileSearch = Nothing
End Sub
Function funcExternerWert(strPfad, strDatei, strTabelle, strBezug)
Dim StrArg As String
' Hier könnte man den für den Pad und die Tabelle konstanten einsetzen
' z.b.: strPfad = "C:\TEMP": StrTabelle = "Tabelle1"
'Pruefung ob die angegebene Datei vorhanden ist
If Right(strPfad, 1) "\" Then strPfad = strPfad & "\"
If Dir(strPfad & strDateiName(n)) = "" Then
funcExternerWert = "Datei nicht vorhanden"
Exit Function
End If
' Externen Bezug zur Abfrage zusammensetzen
StrArg = "'" & strPfad & "[" & strDateiName(n) & "]" & strTabelle & "'!" & Range(strBezug). _
Range("A1").Address(, , xlR1C1)
'MsgBox StrArg
' XLM-Makro ausfuehren
funcExternerWert = ExecuteExcel4Macro(StrArg)
End Function
Sub meine_test()
'Aus der geschlossenen Arbeitsmappe E:\Excel 2000\Beispiele\Bereich markieren.xls
'wird die Zelle D2 eingelesen und in der Zelle A12 eingetragen
' strPfad = "D:\meine Dateien\Eigene Dokumente\Excel\EXCEL\Dienstlich\Arbeitsergebnisse neu\ _
' strDateiName = "PW Finsterwalde.xls"
' strTabelle = "Teil1"
strBezug = "I39"
Sheets("Tabelle1").Range("I39") = Sheets("Tabelle1").Range("I39") + funcExternerWert( _
strPfad, strDateiName, strTabelle, strBezug)
End Sub
Nun habe ich versucht für die konstanten Werte >Range.("I39")
Nun sehe ich den Wald vor Bäumen nicht mehr.
Kann mir jemand helfen meinen Fehler zu lösen.
Meine angedachte Variante:
Option Explicit
'Pfad und Name des Tabellenblattes anpassen
Const strPfad = "D:\meine Dateien\Eigene "
Const strTabelle = "Teil1"
' Dim strPfad As String
' Dim strTabelle As String
Dim strDateiName() As String
Dim strBezug As String
Dim intDateiAnzahl As Integer
Dim intZeile As Integer
Dim n As Integer
Dim datWerte() As Variant
Sub Abfrage_starten()
Call Dateien_auslesen
For n = 1 To intDateiAnzahl
' procExternerBereich
meine_test
Next n
End Sub
Sub Dateien_auslesen()
Dim objFileSearch As Object
Set objFileSearch = Application.FileSearch
With objFileSearch
.LookIn = strPfad
.Filename = "FI*.xls"
.SearchSubFolders = False 'bei True werden alle Unterverzeichnisse mit durchsucht
If .Execute > 0 Then
intDateiAnzahl = .FoundFiles.Count
ReDim strDateiName(1 To intDateiAnzahl)
ReDim datWerte(1 To 3, 1 To intDateiAnzahl)
For n = 1 To intDateiAnzahl
strDateiName(n) = Right(.FoundFiles(n), Len(.FoundFiles(n)) - Len(strPfad) - 1) ' _
nur Dateiname
' MsgBox strDateiName(n)
Next
End If
End With
Set objFileSearch = Nothing
End Sub
Function funcExternerWert(strPfad, strDatei, strTabelle, strBezug)
Dim StrArg As String
' Hier könnte man den für den Pad und die Tabelle konstanten einsetzen
' z.b.: strPfad = "C:\TEMP": StrTabelle = "Tabelle1"
'Pruefung ob die angegebene Datei vorhanden ist
If Right(strPfad, 1) "\" Then strPfad = strPfad & "\"
If Dir(strPfad & strDateiName(n)) = "" Then
funcExternerWert = "Datei nicht vorhanden"
Exit Function
End If
' Externen Bezug zur Abfrage zusammensetzen
StrArg = "'" & strPfad & "[" & strDateiName(n) & "]" & strTabelle & "'!" & Cells(strBezug). _
Range("A1").Address(, , xlR1C1)
'MsgBox StrArg
' XLM-Makro ausfuehren
funcExternerWert = ExecuteExcel4Macro(StrArg)
End Function
Sub meine_test()
Dim i
Dim j
'Aus der geschlossenen Arbeitsmappe E:\Excel 2000\Beispiele\Bereich markieren.xls
'wird die Zelle D2 eingelesen und in der Zelle A12 eingetragen
' strPfad = "D:\meine Dateien\Eigene Dokumente\Excel\EXCEL\Dienstlich\Arbeitsergebnisse neu\ _
' strDateiName = "PW Finsterwalde.xls"
' strTabelle = "Teil1"
For i = 39 To 42
For j = 5 To 15
strBezug = "" & i & "," & j & "" '"I39" '" & i & " , " & j &"
Sheets("Tabelle1").Cells(i, j) = Sheets("Tabelle1").Cells(i, j) + funcExternerWert(strPfad, _
strDateiName, strTabelle, strBezug)
Next j
Next i
End Sub
Für eine Hilfe von Euch bin ich sehr sehr dankbar
Gruß Schmausi