Platzhalter erkennen

[marose67]

Hallo zusammen,

ich durchstöbere mal wieder meine alten Excel Files. Dort habe ich ein Makro gefunden, welches mir eine Auflistung von Files erstellt und diese als Hyperlink auswirft. Nun habe ich versucht dass mir alle Excel Files angezeigt werden. Da ich auch viele alte Files (xls, xla usw.) habe dachte ich mir, dass ich doch mal eben einen Platzhalter "*" mit eingeben könnte um alle Files anzuzeigen. Pustekuchen.

Hier mal der komplette Code:

Microsoft Excel Objekt Tabelle6

Option Explicit 
 
Sub Dateinamen_auflisten() 
Dim FSO As Object 
Dim strPfad As String 
Dim x As Integer 
Dim strGef As Object 
Dim strext As String 
strext = InputBox("Nenne die Extension") 
Application.ScreenUpdating = False 
strPfad = InputBox("Geben Sie den Pfad ein") 
ActiveSheet.UsedRange.Clear 
Set FSO = CreateObject("Scripting.FilesystemObject") 
For Each strGef In FSO.getfolder(strPfad).Files 
  Select Case LCase(FSO.getextensionname(strGef)) 
    Case strext 
    x = x + 1 
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(x, 1), Address:= _
    strGef, TextToDisplay:=strGef.Name 
  End Select 
Next 
Application.ScreenUpdating = True 
End Sub 
 
 

Da ich eventuell auch nur nach *.xlsm suchen werde kann ich somit nicht die Endungen festlegen. Diese Zele erkennt scheinbar das "*"chen nicht weiter geben. Gibt es da vielleicht eine Möglichkeit?

strext = InputBox("Nenne die Extension")

Gruß
Marcus

[JereMaia]

Ich kann mir denken warum das nicht funktioniert. Der Befehl

FSO.getfolder(strPfad).Files


Holt Dir alle Dateinamen. Per "FOR Echo"-Schleife gehst Du alle Dateinamen durch und prüfst "NUR" das Suffix ab (Extension).
Die Idee *.xlsm einzugeben wird so nicht hinhauen, da das * sich auf den Dateinamen bezieht.

Select Case LCase(FSO.getextensionname(strGef))

Diese Zeile prüft ja nur alles ab was NACH dem Punkt kommt. Ich beziehe mich mit dieser Aussage auf Dein Beispiel "*.xlsm"

[marose67]

Hallo Jeremaia,

ist ja nach dem Punkt. xla, xls,xlsm,xlam,xlsx, xlt, xlsb
Ich suchte also nach xls*
Hier mal die Datei ...


  Dateinamen_auflisten_ab_2007.xls (Größe: 21,5 KB / Downloads: 1)
Gruß
Marcus

[JereMaia]

Frage:

Wie sieht es mit diesem Beispielcode für Dich aus? Wäre das das gewünschte Ergebnis für Dich?

Code:

Sub Dateinamen_auflisten()
On Error Resume Next
Dim strPfad As String
Dim x As Integer
Dim strtext As String
Dim a As String

'*** Suffix ************************************************
strtext = Trim(InputBox("Nenne die Extension"))
If (InStr(strtext, ".") = 0) Then strtext = "." & strtext

'*** Verzeichnis ******************************************
strPfad = Trim(InputBox("Geben Sie den Pfad ein"))
If (Right(strPfad, 1) <> "\") Then strPfad = strPfad & "\"


'*** Fielliste durchgehen ********************************
Application.ScreenUpdating = False
ActiveSheet.UsedRange.Clear
a = Dir(strPfad & "*" & strtext, vbNormal)



Do While (a <> "")
    x = x + 1
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(x, 1), Address:=a, TextToDisplay:=a
    a = Dir()
Loop
Application.ScreenUpdating = True


End Sub

Gerade geprüft:
Wenn ich bei der ersten Abfrage für die Extension xls* eingebe und dann den gewünschten Pfad
Erhalte ich tatsächlich alle Excelfiles die in der Extension mindestens die Zeichenfolge xls enthalten.

[marose67]

Hallo Jeremaia,

der Code macht was ich will. Schaue ihn mir jetzt genauer an. Supi.

Gruß
Marcus

[schauan]

Hi Marcus,

hier mal Dein ursprünglicher Code mit einer entsprechenden Änderung - If … und Like statt Select Case. Du solltest dann eventuell noch den strext mit LCase behandeln...

Code:

Sub Dateinamen_auflisten()
Dim FSO As Object
Dim strPfad As String
Dim x As Integer
Dim strGef As Object
Dim strext As String
strext = InputBox("Nenne die Extension")
Application.ScreenUpdating = False
strPfad = InputBox("Geben Sie den Pfad ein")
ActiveSheet.UsedRange.Clear
Set FSO = CreateObject("Scripting.FilesystemObject")
For Each strGef In FSO.getfolder(strPfad).Files
  If LCase(FSO.getextensionname(strGef)) Like (strext) Then
    x = x + 1
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(x, 1), Address:= _
    strGef, TextToDisplay:=strGef.Name
  End If
Next
Application.ScreenUpdating = True
End Sub

[marose67]

Halo André,

habe mir deinen Code kurz angeschaut. Viel hast Du ja nicht ändern müssen. Werde mich jetzt in den Code vertiefen, damit ich ihn begreife. Danke Dir auf alle Fälle.

Gruß
Marcus

[marose67]

Hallo,

kann es sein, dass es Application.Filesearch auch nicht mehr gibt? Ich versuche die ganze Zeit euere Codes auf eine dritte Tabelle abzuändern. Schaffe ich aber nicht. Die Änderungen lösche ich immer ... fange von vorne an ... Der damalige Code:

Microsoft Excel Objekt Tabelle6

Option Explicit 



Sub Dateinmen_auflisten() 

Dim x As Integer 

Dim y As Byte 

Dim strGef As Long 

Dim strPfad(3) As Variant 

strPfad(1) = "C:\02_Excel\06_Excel_allgemein\" 

strPfad(2) = "C:\02_Excel\07_Forumsarbeiten\" 

strPfad(3) = "c:\100_Test\" 

y = 1 

Application.ScreenUpdating = False 

UsedRange.Clear 

For y = 1 To 3 

    With Application.FileSearch 

        .LookIn = strPfad(y) 

        .FileType = msoFileTypeExcelWorkbooks 

        .Execute 

        x = .FoundFiles.Count 

            For strGef = 1 To x 

                ActiveSheet.Hyperlinks.Add Anchor:=Cells(strGef + 2, y), Address:= _

                .FoundFiles(strGef), TextToDisplay:= _

                .FoundFiles(strGef) 

            Next 

    End With 

    Cells(2, y) = strPfad(y) & "  hat " & x & " Einträge" 

    With Worksheets("Break").Cells(2, y).Font 

        .Name = "Arial" 

        .Size = 12 

        .Bold = True 

        .Italic = True 

    End With 

Next 

Application.ScreenUpdating = True 

End Sub 

Mit dieser Tabelle hätte ich gerne einen schnelleren Zugriff auf meine Excel Beispiel. Mit Steuerung F könnte ich dann alles Suchen. Es hat sich ja soviel geändert ... Ich hänge die Datei auch an.

Gruß
Marcus

[schauan]

Hi Marcus,

kann es sein, dass es Application.Filesearch auch nicht mehr gibt?

korekt, ich glaube, das ist schon Jahre im zweistelligen Bereich her …

[marose67]

Hallo André,



naja ... weiß ich jetzt Bescheid. Ich bekomme das noch hin. Muss wirklich viel neues lernen.


Zur Zeit sieht der Code so aus:

Option Explicit



Sub Dateinmen_auflisten()

Dim x As Integer

Dim y As Byte

Dim StrAnzahl As Variant

Dim strPfad(3) As Variant

Dim FSO As Object

Dim strGef As Object

Dim strext As String

strPfad(1) = "C:\02_Excel\06_Excel_allgemein\"

strPfad(2) = "C:\02_Excel\07_Forumsarbeiten\"

strPfad(3) = "c:\100_Test\"

y = 1

Application.ScreenUpdating = False

UsedRange.Clear

For x = 1 To 3

        'x = .FoundFiles.Count 

        For StrAnzahl = 1 To x

            Set FSO = CreateObject("Scripting.FilesystemObject")

                For Each strGef In FSO.getfolder(strPfad(x)).Files

                    If LCase(FSO.getextensionname(strGef)) Like (strext) Then

        x = x + 1

    'Next 

'Next    'End With 

    

    Cells(2, y) = strPfad(y) & "  hat " & x & " Einträge"

    With Worksheets("Break").Cells(2, y).Font

        .Name = "Arial"

        .Size = 12

        .Bold = True

        '.Underline = xlUnderlineStyleSingle 

        .Italic = True

        

    End With

    

Next

Application.ScreenUpdating = True

End Sub

Bekomme ständig die Meldung Next ohne For.

Aber wie geschrieben ... ich finde das Problem noch.
Wünsche Dir ein schönes Wochenende. Grüße deine Frau auch von mir.



Gruß

Marcus