Lesen aus geschlossener Mappe

Lesen aus geschlossener Mappe. ExecuteExcel4Macro(argument)
Eine Funktion benötigt die vier unten angeführten Argumente:
path: Das Laufwerk und den Pfad der geschlossenen Datei (z.B. "C:\Daten")
file: Der Dateiname der Arbeitsmappe (z.B. "MeineDatei.xls")
sheet: Der Name des Tabellenblattes (z.B. "Tabelle1")
ref: Der Zellbezug (z.B. "A1")
Sub HoleWert()
Dim rngZelle As Range
Application.ScreenUpdating = False
For Each rngZelle In ActiveSheet.Range("A1:C10")
rngZelle = GetValue("E:\My_Files\6_Schule\", "09_Fragen.xls", "01", rngZelle.Address)
Next rngZelle
Application.ScreenUpdating = True
End Sub
Function GetValue(path$, file$, sheet$, range_ref$)
Dim arg As String
'Sicherstellen, dass die Datei exisiert
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "Datei nicht gefunden"
Exit Function
End If
'Den Aufruf-String zusammenstellen
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(range_ref).Range("A1").Address(, , xlR1C1)
'Ausführen des XL4-Makros
GetValue = ExecuteExcel4Macro(arg)
End Function
Das obere Beispiel funktioniert also nur, wenn man den Namen des Tabellenblattes weiß, sowie
die Zell-Adresse, deren Wert eingelesen werden soll.
Da eine Mappe mehrere Blätter hat, die ja verschiedene Namen haben, könnte man theoretisch
ein Array aus diesen Namen bilden. Wenn man die Namen der Blätter nicht kennt, stößt man
an Grenzen: um Namen von Blättern zu ermitteln, muss man also eine Arbeitsmappe öffnen.
 
Das folgende Makro durchsucht ein Verzeichnis nach sämtlichen geschlossenen xls-Dateien.
Das Verzeichnis kann per Dialogfeld ausgewählt werden.
Unterverzeichnisse werden berücksichtigt.
Die Treffer werden in die Spalten A bis D des offenen Workbooks geschrieben.
Die gesuchten Werte befinden sich immer in demselben Zellbereich der geschlossenen xls-Dateien.
Dieser Bereich kann entfallen, wenn der Variable 'Laufwerk' ein fester Wert zugewiesen wird.
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private z!
Sub Suchen()
Dim Laufwerk$, Dateien$
'Erste Zeile, in der eine Eintragung erfolgt
z = 2
'Alte Eintragungen löschen
[a2:d65536] = ""
'Den Variablen Laufwerk und Dateien kann auch ein Wert direkt zugewiesen werden.
Laufwerk = GetDirectory("Bitte einen Ordner wählen") 'Ersatz: "E:\Eigene Dateien"
If Laufwerk = "" Then Exit Sub
Dateien = "*.xls"
Dateisuche Laufwerk, Dateien
End Sub
'Ruft das Dialogfeld zur Ordnerauswahl auf
Function GetDirectory(Msg) As String
Dim bInfo As BROWSEINFO, path As String
Dim r As Long, x As Long, pos As Integer
With bInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub Dateisuche(Laufwerk, Dateien)
Dim WB_Name$, Sheet_Name$, Wdhlg, rngZelle As Range, i&, x&
If Right(Laufwerk, 1) <> "\" Then Laufwerk = Laufwerk + "\"
WB_Name = Dir(Laufwerk & Dateien)
Do While Len(WB_Name)
Application.ScreenUpdating = False
'Mappe kurz öffnen um Anzahl der Worksheets zu zählen
Call Count_Sheets(Pfad(Laufwerk & WB_Name) & Datei(Laufwerk & WB_Name), i)
For x = 1 To i
Call List_Sheet(Pfad(Laufwerk & WB_Name) & Datei(Laufwerk & WB_Name), Sheet_Name, x)
'der Range bezieht sich nicht auf das ActiveSheet dieser Mappe !
For Each rngZelle In Range("A1:B10")
'in Zelle E1 werden die Blattnamen dynamisch erzeugt (z.B. Tabelle1)
[e1] = Sheet_Name
'in Zelle E2 werden die Zell-Adressen dynamisch erzeugt (z.B. $A$5)
[e2] = rngZelle.Address
'in Spalte A wird der gefundene Pfad geschrieben
Cells(z, 1) = Pfad(Laufwerk & WB_Name)
'in Spalte B wird der gefundene Dateiname geschrieben
Cells(z, 2) = Datei(Laufwerk & WB_Name)
'in Spalte C wird der Blattname & der Bereich geschrieben
Cells(z, 3) = [e2].Value & " / " & [e1].Value
'in Spalte D wird der gefundene Wert geschrieben
Cells(z, 4).Formula = "='" & Pfad(Laufwerk & WB_Name) & _
"[" & Datei(Laufwerk & WB_Name) & "]" & [e1] & "'!" & [e2]
If Cells(z, 4) <> 0 Then Cells(z, 4) = Cells(z, 4) Else Cells(z, 4) = ""
z = z + 1
Next rngZelle
Next x
WB_Name = Dir()
i = 0
Application.ScreenUpdating = True
Loop
'und dann die Unterverzeichnisse lesen...
WB_Name = Dir(Laufwerk, vbDirectory)
Do While Len(WB_Name)
If (WB_Name <> ".") And (WB_Name <> "..") Then
If (GetAttr(Laufwerk & WB_Name) And vbDirectory) = vbDirectory Then
'Sub neu aufrufen bis alle Unterverzeichnisse abgearbeitet wurden
Dateisuche Laufwerk & WB_Name, Dateien
z = z - 1
Wdhlg = Dir(Laufwerk, vbDirectory)
z = z + 1
Do While Wdhlg <> WB_Name
Wdhlg = Dir()
Loop
End If
End If
WB_Name = Dir()
Loop
On Error GoTo 0
End Sub
Function Datei(Wert As String) As String
Do While InStr(Wert, "\") <> 0
Wert = Right(Wert, Len(Wert) - InStr(Wert, "\"))
Loop
Datei = Wert
End Function
Function Pfad(Wert As String) As String
Dim wert1$
wert1 = Wert
Do While InStr(wert1, "\") <> 0
wert1 = Right(wert1, Len(wert1) - InStr(wert1, "\"))
Loop
Pfad = Left(Wert, Len(Wert) - Len(wert1))
End Function
Sub List_Sheet(WB_Nam, Sheet_Name, i)
Dim WB As Workbook
Set WB = Workbooks.Open(WB_Nam)
' ermittelt Namen des Worksheets
Sheet_Name = WB.Worksheets(i).Name
WB.Close savechanges:=False
Set WB = Nothing
End Sub
Sub Count_Sheets(WB_Nam, i)
Dim WB As Workbook
Set WB = Workbooks.Open(WB_Nam)
' zählt Worksheets eines Workbooks
i = WB.Worksheets.Count
WB.Close savechanges:=False
Set WB = Nothing
End Sub

Mehr Tipps: String-Ersetzung mit Replace

Sponsoren und Investoren

Sponsoren und Investoren sind jederzeit herzlich willkommen!
Wenn Sie die Information(en) auf dieser Seite interessant fanden, freuen wir uns über eine kleine Spende. Empfehlen Sie uns bitte auch in Ihren Netzwerken (z. B. Twitter, Facebook oder Google+). Herzlichen Dank!

Nach oben Sitemap
Impressum & Kontakt