VBA Ordner auswählen bestimmte Dateien auslesen

Tom · 2017-01-20T08:48:33+00:00

Guten Tag, ich hoffe hier kann mir jemand helfen. Ich möchte einen ordner auswählen per Dialog der mir bestimmte Dateinamen ausliesst und kopiert dann jeweils ein Worksheet davon erstellt. Die Dateinamen heißen Tab1.3, Tab1.4.... Ich hoffe jemand kann mir hier helfen !!

Ich möchte gern mehrere Dateien aus einen Ordner einlesen aber nur bestimmte. In diesen Ordner sind ich 20-30 xls Dateien aber ich brauch nur 5-6 Dateien die in eine Arbeitsmappe zusammengeführt werden sollen und am besten jede eine eigenen Worksheet bekommt als die Datei Tab1.3.xls findet man dann im Worksheet2 und die nächste im Worksheet3. Das wäre am besten wenn ich nur den Pfad auswähle und er nimmt automatisch immer die Datei die ich brauche die haben auch immer den selben Namen.
ich hab auch schon Code gefunden aber ich weis nicht wie ich weiter komme hier ist der Code:

Option Explicit
'by J.Ehrensberger
Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional  _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object
Set mobjFSO = CreateObject("Scripting.FileSystemObject")
Set mfsoFolder = mobjFSO.GetFolder(InitialPath)
On Error Resume Next
For Each mfsoFile In mfsoFolder.Files
If Not mfsoFile Is Nothing Then
If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Files(UBound(Files)) = mfsoFile
End If
End If
Next
If SubFolders Then
For Each mfsoSubFolder In mfsoFolder.SubFolders
FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Sub test()
Dim a
Dim result As Long, l As Long, strFolder As String, strExt As String
strFolder = fncBrowseForFolder
If strFolder = "" Then Exit Sub
strExt = "xls" 'gesuchte Dateiendung
result = FileSearchFSO(a, strFolder & "\", "*." & strExt, True)
If result  0 Then
For l = 0 To UBound(a)
'hier der Code zum Öffnen/Auslesen der Dateien
Next
End If
End Sub

Hallo
in Spalte A stehen die Dateien, die berücksichtigt werden sollen.

Tabelle1

	A
1	Tab1.3
2	Tab1.4
3	Tab1.7
4	Tab1.8
5	Tab1.9
6	Tab1.10

http://excel-inn.de/dateien/vba_beispiele/tabellenanzeige_in_html_addin.zip

http://Hajo-Excel.de/tools.htm

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 21.10 einschl. 64 Bit

In ein normales Modul:

Option Explicit 
 
 Sub Dateien_Verzeichnis()  
    On Error GoTo Fehler 
    Dim Dlg As FileDialog, Pfad As String, Ext As String 
    Dim Datei, WBM As Workbook, WBC As Workbook 
    Dim TBM As Worksheet, TBC As Worksheet 
    Set Dlg = Application.FileDialog(msoFileDialogFolderPicker) 'Verzeichnis wählen 
    Set WBM = ThisWorkbook 
     
    'Vorgaben 
    Set TBM = WBM.Sheets("Tabelle1") 
    Ext = ".xlsx" 
    Dlg.InitialFileName = "C:\Temp\" 'Welches Verzeichnis soll voreingestellt sein" 
 
 
    Application.ScreenUpdating = False 
    If Dlg.Show = True Then 
        Pfad = Dlg.SelectedItems(1) & "\" 
        For Each Datei In TBM.Columns(1).SpecialCells(xlCellTypeConstants, 2) 
            If Dir(Pfad & Datei & Ext) = "" Then 
                MsgBox Pfad & Datei & Ext & "  existiert nicht" 
            Else 
                 
                'Altes Blatt löschen 
                Application.DisplayAlerts = False 
                On Error Resume Next 
                WBM.Sheets(Datei.Text).Delete 
                On Error GoTo Fehler 
                Application.DisplayAlerts = True 
                 
                 
                'Datei öffnen 
                Set WBC = Workbooks.Open(Filename:=Pfad & Datei.Text & Ext) 
                 
                'Blatt kopieren 
                WBC.Sheets(1).Copy After:=WBM.Sheets(WBM.Sheets.Count) 
                 
                 
                'Blatt umbenennen 
                WBM.Sheets(WBM.Sheets.Count).Name = Datei 
                 
                'Datei schließen 
                WBC.Close SaveChanges:=False 
                 
            End If 
        Next 
    End If 
    WBM.Sheets(1).Activate 
     
    Err.Clear 
Fehler: 
    Application.DisplayAlerts = True 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear 
End Sub

LG UweD

VBA Ordner auswählen bestimmte Dateien auslesen

Forumthread: VBA Ordner auswählen bestimmte Dateien auslesen

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

VBA Ordner auswählen und bestimmte Dateien auslesen

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)

VBA Ordner auswählen bestimmte Dateien auslesen

Forumthread: VBA Ordner auswählen bestimmte Dateien auslesen

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Infobox / Tutorial

VBA Ordner auswählen und bestimmte Dateien auslesen

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread