AW: Inhaltsangaben zusammenführen
10.03.2014 12:04:15
fcs
Hallo Erdogan,
hier Makros, die du in einem allgemeine Modul der Datei "Gesammelter Inhalt.xls" einfügen kannst.
Gruß
Franz
'Code in einem allgemeinen Modul
Option Explicit
Public lCount As Long
Public arrFiles() As String
Sub ListFiles(ByVal sFolder As String, _
Optional ByVal sFilter As String = "*.*", _
Optional ByVal bSubfolders As Boolean = False, _
Optional ByVal bFullname As Boolean = False)
'Dateiliste gemäß übergebenen Parametern in einem Array erstellen
'sFolder = Ordner der nach Dateien durchsucht werden soll
'sFilter = Filter für den Dateinamen, der per Funktion Like verglichen wird
'bSubfolders = Unterverzeichnisse durchsuchen Ja/Nein
'bFullname = Dateiname mit/ohne Verzeichnis listen
Dim objFSO As Object
Dim objFolder As Object, objSubfolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
If sFolder = "" Then GoTo Beenden
'Ordner-Objekt setzen
Set objFolder = objFSO.GetFolder(sFolder)
'Dateien im Ordner abarbeiten
For Each objFile In objFolder.Files
If LCase(objFile.Name) Like LCase(sFilter) Then
lCount = lCount + 1
ReDim Preserve arrFiles(1 To lCount)
If bFullname = True Then
arrFiles(lCount) = objFile.Path
Else
arrFiles(lCount) = objFile.Name
End If
End If
Next
If bSubfolders = True Then
'Unterverzeichnisse nach Dateinamen durchsuchen
For Each objSubfolder In objFolder.subFolders
Call ListFiles(sFolder:=objSubfolder.Path, sFilter:=sFilter, _
bSubfolders:=bSubfolders, _
bFullname:=bFullname)
Next
End If
Beenden:
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
Sub InhalteSammeln()
'Inhalte aus den Dateien in den Unterordnern in einem Blatt der aktiven _
Arbeitsmappe sammeln
Dim wkbQ As Workbook, wksQ As Worksheet, rngQ As Range, ZeileQL As Long
Dim varVerzeichnis As Variant, lFile As Long
Dim wksZ As Worksheet, ZeileZ As Long
If MsgBox("Liste der Inhaltsverzeichnisse jetzt neu erstellen?", _
vbQuestion + vbOKCancel, _
"Erstellen I N H A L T S V E R Z E I C H N I S") = vbCancel Then Exit Sub
'Tabelle für gesammelte Inhalte setzen
Set wksZ = Workbooks("Gesammelter Inhalt.xls").Worksheets(1) 'Blattindex/Blattname ggf. _
anpassen
varVerzeichnis = ActiveWorkbook.Path
'Dateiliste erstellen
lCount = 0
Erase arrFiles
Call ListFiles(sFolder:=varVerzeichnis, sFilter:="*.xls*", _
bSubfolders:=True, _
bFullname:=True)
'Dateiinformationen in Tabellenblatt eintragen
With wksZ
'Alte Liste Löschen
.UsedRange.EntireRow.Clear
Application.ScreenUpdating = False
If lCount > 0 Then
ZeileZ = 1
For lFile = 1 To lCount
Application.StatusBar = "Kopiere Datei " & lFile & " von " & lCount _
& " : " & arrFiles(lFile)
'Dateien im Hauptordner überspringen
If LCase(Left(arrFiles(lFile), InStrRev(arrFiles(lFile), "\") - 1)) _
LCase(varVerzeichnis) Then
'Quelldatei schreibgeschützt öffnen
Set wkbQ = Application.Workbooks.Open(arrFiles(lFile), _
UpdateLinks:=False, ReadOnly:=True)
'Quelltabelle setzen
Set wksQ = wkbQ.Worksheets(1)
'Quelldatenbereich setzen und kopieren
With wksQ
'letzte Zeile in Spalte A
ZeileQL = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rngQ = .Range(.Cells(1, 1), .Cells(ZeileQL, 3))
End With
rngQ.Copy Destination:=.Cells(ZeileZ, 1)
'Dateiordner einfügen in Spalte D - ggf. weglassen
.Range(.Cells(ZeileZ, 4), .Cells(ZeileZ + rngQ.Rows.Count - 1, 4)) _
= Mid(wkbQ.Path, Len(varVerzeichnis) + 2)
'nächste Einfügezeile setzen
ZeileZ = ZeileZ + rngQ.Rows.Count + 2
'Quelldatei wieder schliessen.
wkbQ.Close savechanges:=False
Set wkbQ = Nothing
Set wksQ = Nothing
Set rngQ = Nothing
End If
Next
Else
MsgBox "Keine Dateien im Verzeichnis gefunden!"
End If
Application.ScreenUpdating = True
End With
lCount = 0
Erase arrFiles
Beenden:
Set wksZ = Nothing
Application.StatusBar = False
End Sub