Dateien aus Ordnern einlesen Excel VBA

[nikiboy]

Hallo,

ich bräuchte ein wenig Hilfe mit einem Makro zum auslesen von Ordnerinhalten. Ein Teil des Codes habe ich bereits schon (nicht von mir selbst geschrieben):

Code:

Sub Makro_einlesen()

Range("B1:B3000").Delete 'Spalte E löschen

Dim c As Range, tmp
Dim objFSO As Object
Dim objFolder As Object
Dim strPfad As String
Dim objSubfolder As Object, colSubfolders As Object
Dim I As Integer
I = 2
Dim ws As Worksheet
Set ws = ActiveSheet
strPfad = "irgendein Pfad"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPfad)
Set colSubfolders = objFolder.Subfolders
For Each objSubfolder In colSubfolders
I = I + 1

Range("B" & I).Value = objSubfolder.Name
Next objSubfolder
Set objFolder = Nothing
Set colSubfolders = Nothing
Set objFSO = Nothing

'eingelesene Ordner sortieren

ActiveSheet.Range("E3:E2000").Select
Selection.Sort Key1:=ActiveSheet.Range("B3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

     
     
MsgBox CStr(I - 2) & " Werte gefunden", vbOKOnly, "Erfolgreich"

End Sub

Das Makro schaut in dem Pfad nach allen Ordnern und schreibt die Namen in Spalte B. Nun existieren in manchen Ordnern ein Pdf File oder manchmal auch noch ein Word File. Da müssten dann entsprechende Kreuze gesetzt werden (die Files habe alle unterschiedliche Namen, ich müsste nur wissen ob überhaut ein File existiert). Dann wäre es noch cool, wenn man die existierenden Ordner direkt neben die Ordner von Spalte A schreiben könnte.

Danke im Vorraus.

[Werner.M]

Hallo,

bei Herber.de auch, dort gibt es auch schon einen Lösungsvorschlag.

Gruß Werner

[Kuwer]

Hallo,

vielleicht so:

Sub Ordner_einlesen()
  Dim rngF As Range
  Dim strPfad As String
  
  strPfad = "C:\Test\"
  Range("A3").CurrentRegion.Resize(, 3).Offset(, 1) = ""
  For Each rngF In Range("A3").CurrentRegion.Cells
    If Len(Dir(strPfad & rngF.Value, vbDirectory)) Then
      rngF.Offset(, 1).Value = "x"
      If Len(Dir(strPfad & rngF.Value & "\*.pdf", vbNormal)) Then
        rngF.Offset(, 2).Value = "x"
      End If
      If Len(Dir(strPfad & rngF.Value & "\*.doc*", vbNormal)) Then
        rngF.Offset(, 3).Value = "x"
      End If
    End If
  Next rngF
End Sub

Gruß Uwe

[snb]

Oder

Code:

Sub M_snb()
   sn=createobject("wsript.shell").exec("cmd /c Dir ""G:\OF\*.*"" /a-d/b/s").stdout.readall

  st=filter(sn,".pdf")
  if ubound(st)>-1 then sheet1.cells(1,1).resize(ubound(st)+1)=application.transpose(st)

  st=filter(sn,".doc*")
  if ubound(st)>-1 then sheet1.cells(1,2).resize(ubound(st)+1)=application.transpose(st)

  st=filter(sn,".xls*")
  if ubound(st)>-1 then sheet1.cells(1,3).resize(ubound(st)+1)=application.transpose(st)
End Sub