Tabelle mit Ordnerinhalt abgleichen und ergänzen

Private Sub CommandButton1_Click()
'Button "Analysieren"
'Variablen Deklaration
Dim app_pfadabfrage As Object
Dim pfad_suche As Variant
Dim pfad_auswahl As String
Dim dateisystem As Object
Dim dateiverzeichnis As Object
Dim fDatei As Object
Dim fdateien As Object
Dim strDat As String
Dim zeile As Integer
Dim teil_pfad_1 As String
Dim dateiname_komplett As String
Dim wb As Workbook
Dim rngEinfüg As Range
Dim kopierzeile As String
Dim einfügezeile As String
Dim zelle As Object
Dim Spalte_dateiname As Range
Dim teil_pfad_2 As String
Dim dateiname As String
Dim hyper As Object
'Pfadabfrage
'ruft den "Verzeichnis-Dialog" auf damit der Benutzer den Pfad bzw. Ordner
wählen kann, der analysiert werden soll.
Set app_pfadabfrage = CreateObject("Shell.Application")
Set pfad_suche = app_pfadabfrage.BrowseForFolder
(0, "Ordner auswählen", &H1000,17)
'führt den Benutzer durch die Abfrage und speichert den ausgewählten Pfad für
einen späteren Zugriff im Tabellenblatt "Parametereinstellungen" in der Zelle B1
On Error Resume Next
pfad_auswahl = pfad_suche.items().Item().Path
Worksheets("Parametereinstellungen").Range("B1").Value = pfad_auswahl & "\"
If pfad_auswahl = "" Then Exit Sub
On Error GoTo 0
'Dateinamen ziehen
'nimmt den vorher gewählten Pfad als Basis
pfad_auswahl = Worksheets("Parametereinstellungen").Range("B1").Value
'Grundlage zur Abfrage der Ordnerstruktur, scripting stellt die Typbibliothek dar
Set dateisystem = CreateObject("scripting.FileSystemObject")
'gibt dem System an welcher Ordner zur Analyse herangezogen werden soll, in
diesem Fall wieder Verweis auf den bereits ausgewählten Pfad
Set dateiverzeichnis = dateisystem.getFolder(pfad_auswahl)
'zieht sich die einzelnen Dateien aus dem Ordner
Set fdateien = dateiverzeichnis.Files
'setzt in der Übersicht den Start in der Menüleiste und arbeitet sich dann runter
zeile = 3
'zieht sich nun die Dateinamen
For Each fDatei In fdateien
If InStr(fDatei, "") > 0 Then
zeile = zeile + 1
Cells(zeile, 8) = fDatei.Name
End If
Next fDatei
'Kopier-/Einfüge-Prozess; mit diesen Schritten zieht sich das Programm eine
Vielzahl von Feldern aus den jeweiligen Dokumenten im Ordner
'nimmt den vorher gewählten Pfad als Basis
pfad_auswahl = Worksheets("Parametereinstellungen").Range("B1").Value
'Pfadnamen anpassen
dateiname_komplett = Dir(pfad_auswahl & "*.xlsm")
'Deklaration vor Schleife, ab dieser Zeile werden die Daten in die
Übersichtstabelle übernommen
einfügezeile = 4
'Kernprozess, Schleife, läuft solange, bis kein Dateiname bzw. keine Datei mehr
im Ordner gefunden wird
While dateiname_komplett  ""
Application.ScreenUpdating = False
'öffnet zum Start die erste Datei
Set wb = Workbooks.Open(pfad_auswahl & dateiname_komplett)
'kopiert, wechselt das Fenster, fügt ein, wechselt wieder das Fenster
usw. (bei den nachfolgenden Blöcken analog nur die kopierten und
eingefügten Werte sind anders)
'Stammnummer ziehen
ActiveWorkbook.Worksheets("Laufzettel").Range("E35").Copy
Windows("GB-BHF-Stammdaten_Erfassung_Laufzettel_Übersicht.xlsm").Activate
ActiveWorkbook.Worksheets("Übersicht").Range("J" &
einfügezeile).PasteSpecial Paste:=xlValues
Windows(dateiname_komplett).Activate
'Kennung ziehen
ActiveWorkbook.Worksheets("Laufzettel").Range("D4").Copy
Windows("GB-BHF-Stammdaten_Erfassung_Laufzettel_Übersicht.xlsm").Activate
ActiveWorkbook.Worksheets("Übersicht").Range("C" &
einfügezeile).PasteSpecial Paste:=xlValues
Windows(dateiname_komplett).Activate
'Name Altsystem ziehen
ActiveWorkbook.Worksheets("Laufzettel").Range("D28").Copy
Windows("GB-BHF-Stammdaten_Erfassung_Laufzettel_Übersicht.xlsm").Activate
ActiveWorkbook.Worksheets("Übersicht").Range("I" &
einfügezeile).PasteSpecial Paste:=xlValues
'Checkboxen abfragen
Windows(dateiname_komplett).Activate
If ActiveWorkbook.Worksheets("Laufzettel").Shapes("Kontrollkästchen
26").DrawingObject.Value = 1 Then
Windows("GB-BHF-Stammdaten_Erfassung_Laufzettel_Übersicht.xlsm").Activate
ActiveWorkbook.Worksheets("Übersicht").Range("K" & einfügezeile) = "X"
Else
Windows("GB-BHF-Stammdaten_Erfassung_Laufzettel_Übersicht.xlsm").Activate
ActiveWorkbook.Worksheets("Übersicht").Range("K" & einfügezeile) = ""
End If
Windows(dateiname_komplett).Activate
If ActiveWorkbook.Worksheets("Laufzettel").Shapes("Kontrollkästchen
27").DrawingObject.Value = 1 Then
Windows("GB-BHF-Stammdaten_Erfassung_Laufzettel_Übersicht.xlsm").Activate
ActiveWorkbook.Worksheets("Übersicht").Range("L" & einfügezeile) = "X"
Else
Windows("GB-BHF-Stammdaten_Erfassung_Laufzettel_Übersicht.xlsm").Activate
ActiveWorkbook.Worksheets("Übersicht").Range("L" & einfügezeile) = ""
End If
Windows(dateiname_komplett).Activate
If ActiveWorkbook.Worksheets("Laufzettel").Shapes("Kontrollkästchen
28").DrawingObject.Value = 1 Then
Windows("GB-BHF-Stammdaten_Erfassung_Laufzettel_Übersicht.xlsm").Activate
ActiveWorkbook.Worksheets("Übersicht").Range("M" & einfügezeile) = "X"
Else
Windows("GB-BHF-Stammdaten_Erfassung_Laufzettel_Übersicht.xlsm").Activate
ActiveWorkbook.Worksheets("Übersicht").Range("M" & einfügezeile) = ""
End If
'öffnet zum Schluss immer das Fenster aus dem kopiert wurde und schließt
danach diese Datei, sodass nur noch die Übersicht geöffnet bleibt
Windows(dateiname_komplett).Activate
ActiveWorkbook.Close
'erhöht den Zähler der Schleife um 1, bzw. wandert eine Zeile in der
Übersichtstabelle nach unten um die nächsten Werte auszufüllen
einfügezeile = einfügezeile + 1
dateiname_komplett = Dir
Application.ScreenUpdating = True
Wend
'Cleanup der Variablen
Set rngEinfüg = Nothing
Set wb = Nothing
'Hyperlinks erstellen
'die Angabe der Hyperlinks muss in zwei Teilen geschehen, da sich ein Teil aus dem
Ordnerpfad an sich zusammensetzt und ein Teil aus einem variablen Dateinamen
'Pfadangabe 1. Teil, 2. Teil entsteht durch Zeile, dem Programm wird gesagt,
dass es ab Zeile 4 in der Übersichtstabelle anfangen soll die Hyperlinks
zusammenzusetzen
zeile = 4
pfad_komplett = Worksheets("Parametereinstellungen").Range("B1").Value
dateiname = Cells(zeile, "H").Value
'Angabe, in welche Spalte die Hyperlinks übertragen werden sollen
Set Spalte_dateiname = Range("A4:A3003")
'Schleife zur Erstellung der Hyperlinks
For Each zelle In Spalte_dateiname
If zelle = "" Then Exit For
dateiname = Cells(zeile, "H").Value
zeile = zeile + 1
ActiveSheet.Hyperlinks.Add anchor:=zelle, Address:=pfad_komplett & dateiname
Next
End Sub