AW: Werte in einem Excel-File ändern
21.10.2019 15:54:30
Klexy
Das sollte dir weiterhelfen:
Sub OrdnerAuslesen()
AktivesMakro_o = AktivesMakro
AktivesMakro = "OrdnerAuslesen"
' https://www.makro-excel.de/2017/01/31/dateinamen-eines-verzeichnisses-mit-vba-auslesen- _
und-in-excel-schreiben/
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object
Dim Pfad As String
Dim i As Long
Dim Liste As String
If ActiveSheet.UsedRange.Rows.Count > 1 Then
MsgBox vbCr & _
"Kein leeres Tabellenblatt!" & vbCr & vbCr & _
"Leeres Tabellenblatt wird in der aktiven Datei erstellt." & vbCr & _
vbCr & vbCr & _
"____________________________________" & vbCr & _
" Makro: _" & AktivesMakro & "_ ", vbCritical
Worksheets.Add(After:=ActiveSheet).Name = "Dateien"
End If
Pfad = InputBox(vbCr & vbCr & "Bitte Pfad eingeben" & vbCr & "", "Pfad als Variable anlegen" _
)
Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder(Pfad)
Set objDateienliste = objVerzeichnis.Files
i = 1
ActiveSheet.Cells(i, 1) = "Dateiname"
ActiveSheet.Cells(i, 2) = "Pfad"
i = i + 1
For Each objDatei In objDateienliste
If Not objDatei Is Nothing Then
' If Right(objDatei.Name, 4) = ".pdf" Then ' nur bestimmte Dateitypen
ActiveSheet.Cells(i, 1) = objDatei.Name
ActiveSheet.Cells(i, 2) = objDatei.Path
i = i + 1
' End If
End If
Next objDatei
Columns("A:B").AutoFit
Call UnterOrdnerAuslesen(objVerzeichnis, i)
AktivesMakro = AktivesMakro_o
End Sub
Sub UnterOrdnerAuslesen(ByVal strDateipfad As String, i As Long)
AktivesMakro_o = AktivesMakro
AktivesMakro = "UnterOrdnerAuslesen"
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objUnterordner As Object
Dim objDatei As Object
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder(strDateipfad)
For Each objUnterordner In objVerzeichnis.SubFolders
For Each objDatei In objUnterordner.Files
If Not objDatei Is Nothing Then
' If Right(objDatei.Name, 4) = ".pdf" Then ' nur bestimmte Dateitypen
ActiveSheet.Cells(i, 1) = objDatei.Name
ActiveSheet.Cells(i, 2) = objUnterordner.Path
i = i + 1
' End If
End If
Next objDatei
Call UnterOrdnerAuslesen(objUnterordner.Path, i)
Columns("A:B").AutoFit
Next objUnterordner
Columns("A:B").AutoFit
End Sub
