AW: unbekannte Dateiname mit unbekannten Tabellennamen
08.07.2010 10:53:41
Martin
Hallo Christof,
schade, keine Antwort. Also gehe ich einfach mal davon aus, dass die Excel-Dateien alle geöffnet werden sollen. Kopiere den Code in ein normales VBA-Modul und starte anschließend das Makro "XLS_Ordner".
Viele Grüße
Martin
Option Explicit
Dim arr As Variant
Dim sPath As String, sPattern As String
Dim sFile As String
Dim iCounter As Integer
Dim StrNewDir As String
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
'Aufruf des Dialogs zur Ordnerauswahl
Function GetDirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(msg) Then bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus." Else bInfo. _
lpszTitle = msg
bInfo.ulFlags = &H1
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
Function arrAll(sPath As String, sPattern As String) As Variant
Dim arr()
iCounter = 0
If Right(sPath, 1) "\" Then sPath = sPath & "\"
sFile = Dir(sPath & sPattern)
Do While sFile ""
iCounter = iCounter + 1
ReDim Preserve arr(1 To iCounter)
arr(iCounter) = sFile
sFile = Dir()
Loop
arrAll = arr
End Function
Sub XLS_Ordner()
ThisWorkbook.Activate
'Hauptprozedur - ruft den Dialog zur Auswahl eines Ordners auf
Cells.ClearContents
StrNewDir = GetDirectory("Verzeichnis mit Excel-Dateien (*.xls) auswählen:")
If StrNewDir = "" Then Exit Sub
If Right(StrNewDir, 1) "\" Then StrNewDir = StrNewDir & "\"
Application.ScreenUpdating = False
sPath = StrNewDir
sPattern = "*.xls"
arr = arrAll(sPath, sPattern)
For iCounter = 1 To UBound(arr)
Workbooks.Open Filename:=sPath & arr(iCounter), UpdateLinks:=0
Next iCounter
End Sub