| 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 |
|
zurück