Teillösung
20.12.2008 12:18:00
Tino
Hallo,
keine komplette Lösung, aber einen Anfang.
Funktioniert auch unter xl2007, sollte es mal erforderlich sein.
Mit diesem Code, werden alle Unterordner als Register angelegt und die Dateien in Spalte A aufgelistet.
Tabellen anlegen und Dateien auflisten ist mit einer Prüfung verbunden, somit dürfte es keinen doppelten Einträgen geben.
Die Tabellen werden im der aktuellen Datei angelegt.
Im Code stehen auch einige Kommentare, die sollten Dir helfen den Code zu verstehen.
Viel Spaß damit und noch Frohe Weihnachten.
Modul Modul1
Option Explicit
Dim Liste As String
Dim FS As Object
Dim varFolder
Sub ListOrdner(myFolder, Optional sFilter As String = "*.*")
Dim myFile As Object, mySubfolders As Object
Set myFolder = FS.getfolder(myFolder)
On Error GoTo FehlerZugriff
For Each myFile In myFolder.Files
If myFolder = varFolder Then Exit For
If myFile.Path Like sFilter Then
Liste = Liste & myFile.Path & ">"
End If
Next
For Each mySubfolders In myFolder.subfolders
Liste = Liste & "<" & mySubfolders.Path & ">"
ListOrdner mySubfolders, sFilter
Next
FehlerZugriff:
Err.Clear
Set myFile = Nothing: Set mySubfolders = Nothing: Set myFolder = Nothing
End Sub
Sub Start()
Dim sArea() As String, sArea2() As String
Dim sFileFilter As String, sTabellen As String, OName As String, sDateiName As String
Dim A As Long, B As Long, LCol As Long
Dim InList
Dim oTab As Worksheet
Const InfoText As String = "Bitte warten!"
Set FS = CreateObject("Scripting.FileSystemObject")
sFileFilter = "*.xls" 'Filtefilter
'es werden nur die Unterordner durchsucht und gelistet
varFolder = "F:\" 'welcher Ordner?
'Tabellennamen für Prüfung in einen String
For A = 1 To ThisWorkbook.Sheets.Count
sTabellen = sTabellen & Sheets(A).Name & "<>"
Next A
With Application
.StatusBar = InfoText
.ScreenUpdating = False
ListOrdner varFolder, sFileFilter
sArea = Split(Liste, "<")
For A = Lbound(sArea) To Ubound(sArea)
sArea2 = Split(sArea(A), ">")
If Ubound(sArea2) > 1 Then
LCol = LCol + 1
For B = Lbound(sArea2) To Ubound(sArea2)
If B = 0 Then
'Tabellenname, max 31 Zeichen
OName = Left$(Right$(sArea2(B), Len(sArea2(B)) - InStrRev(sArea2(B), "\")), 31)
'Sonderzeichen entfernen
OName = Replace(OName, "\", "")
OName = Replace(OName, "?", "")
OName = Replace(OName, "!", "")
OName = Replace(OName, "/", "")
OName = Replace(OName, "[", "")
OName = Replace(OName, "]", "")
OName = Replace(OName, "*", "")
'Ist Tabelle in Liste?
If sTabellen Like "*" & OName & "<>*" Then
Set oTab = Sheets(OName)
Else
'Tabelle nicht in Liste, anlegen
Sheets.Add , ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Set oTab = ActiveSheet
oTab.Name = OName
oTab.Cells(1, 1) = "Dateiname": oTab.Cells(1, 1).Font.Bold = True
End If
Else
'Datei in Liste
With oTab
sDateiName = Right$(sArea2(B), Len(sArea2(B)) - InStrRev(sArea2(B), "\"))
InList = Application.Match(sDateiName, .Columns(1), 0)
If Not IsNumeric(InList) Then
'Datei nicht in Liste, schreiben
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = sDateiName
End If
End With
End If
Next B
End If
Next A
.ScreenUpdating = True
.StatusBar = False
End With 'Application
Erase sArea: Erase sArea2
Set FS = Nothing: Set varFolder = Nothing
End Sub
Gruß Tino
www.VBA-Excel.de