Gucken ob Ordner vorhanden sind

Computer: Software & Programmierung Visual Basic
#1

Hi zusammen,

ich habe in Spalte A Seriennummern und in einem Ordner weitere Unterordner die jeweils die Namen der Seriennummern tragen.
Ich habe bis jetzt schonmal eine Sub die nachguckt ob wirklich zu jeder Seriennummer ein Ordner existiert und mir die Seriennummern zu denen kein Ordner existiert farblich markiert und den Namen der jeweiligen Zelle am Rand rausschreibt.
Diese Excel Datei mit den Seriennummern wird von Zeit zu Zeit aktualisiert, so das irgendwann auch Ordner vorhanden sein werden zu denen in der Excel Datei keine entsprechende Seriennummer mehr vorhanden ist.
Jetzt wollte ich fragen ob es möglich ist meine Ursprüngliche Sub so zu erweitern, dass sie mir auch anzeigt/rausschreibt welche Ordner vorhanden sind ohne das es für diese noch eine entsprechende Seriennummer gibt.
Das ist die Sub die ich bis jetzt verwende:
'Gucken ob alle Ordner vorhanden sind

Sub Vorhanden()
Dim fso, Zei As Long
Const Pfad As String = „D:\Documents and Settings\dejhbf05\Desktop\Seriennummer PDF’s“ 'anpassen
With Worksheets(„Rental“) 'andere auch?
If .Columns(1).Interior.ColorIndex = xlNone Then

Set fso = CreateObject(„Scripting.FileSystemObject“)
For Zei = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(Zei, 1).Value „“ And Not fso.folderexists(Pfad & .Cells(Zei, 1).Value) Then
'MkDir (Pfad & .Cells(Zei, 1).Value) 'Ordner erstellen die nicht existieren
.Cells(Zei, 1).Interior.ColorIndex = 34 'Zellen einfärben wenn Ordner nicht existieren
.Range(„AE2“).Value = .Range(„AE2“).Value & „,“ & .Cells(Zei, 1).Address(0, 0) 'anzeigen welche fehlen
End If

Next Zei
Else: .Columns(1).Interior.ColorIndex = xlNone
.Range(„AE2“).Value = „“
End If
End With

End Sub

Danke im Vorraus schonmal.

MFG
Alpenjodler

#2

Ist die Frage zu unverständlich oder weiß dafür niemand eine Lösung?

#3

Jetzt wollte ich fragen ob es möglich ist meine Ursprüngliche
Sub so zu erweitern, dass sie mir auch anzeigt/rausschreibt
welche Ordner vorhanden sind ohne das es für diese noch eine
entsprechende Seriennummer gibt.

Hallo AJ,

Sub Vorhanden()
Dim fso, Zei As Long, objfolder
Const Pfad As String = "c:\test\" 'anpassen
Set fso = CreateObject("Scripting.FileSystemObject")
With Worksheets(1) ' anpassen
 .Columns(1).Interior.ColorIndex = xlNone
 .Range("AE2:AE3").Value = ""
 For Zei = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
 If .Cells(Zei, 1).Value "" And Not fso.folderexists(Pfad & .Cells(Zei, 1).Value) Then
 'MkDir (Pfad & .Cells(Zei, 1).Value) 'Ordner erstellen die nicht existieren
 .Cells(Zei, 1).Interior.ColorIndex = 34 'Zellen einfärben wenn Ordner nicht existieren
 .Range("AE2").Value = .Range("AE2").Value & "," & .Cells(Zei, 1).Address(0, 0) 'anzeigen welche fehlen
 End If
 Next Zei
 For Each objfolder In fso.getfolder(Pfad).subfolders
 If Application.CountIf(.Columns(1), objfolder.Name) = 0 Then
 .Range("AE3").Value = .Range("AE3").Value & "," & objfolder.Name
 End If
 Next objfolder
End With
End Sub

Gruß
Reinhard

#4

Funktioniert wie geschmiert, danke.