Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 21:51:33
Idee für Grafik
26.04.2024 21:29:07
PQ zufällige Reihenfolge
26.04.2024 17:18:47
Große Datenmenge in komplexes Diagramm verpacken
26.04.2024 16:22:47
Aktualisierung Verknüpfung bei geschlossener Quelldatei
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1784to1788
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1784to1788
1784to1788
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Dateiliste mit Dateieigenschaften Category

Dateiliste mit Dateieigenschaften Category
04.10.2020 15:22:18
Thomas
Hallo, ich möchte mir eine Dateiliste aller XLSM erstellen und dazu die Dateieigenschaften (Category,Keywords, Comments, ect.) einlesen. Also nicht die Standard Sachen wie Erstelldatum Filename.
Ich kann nur das ActiveWorkbook abfragen, oder? Da werden die Infos auch ausgegeben. Aber ich greife ja von außten auf den Ordner zu ohne die Datei zu öffnen.
Die Liste funktioniert ja schon
Dim FileInfoCategory As String
FileInfoCategory = ActiveWorkbook.BuiltinDocumentProperties("Keywords")

27
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
keine Frage nur Aufruf zur Teilnahme oT
04.10.2020 15:37:31
Hajo_Zi
Falscher Beitrag OT
04.10.2020 15:56:29
Hajo_Zi
noch offen
04.10.2020 15:57:48
Hajo_Zi
Beitrag an fascher Stelle
AW: Dateiliste mit Dateieigenschaften Category
04.10.2020 17:50:49
Thomas
Danke, schau ich mir an. Andernfalls schreibe ich meine Codezeile in das Feld des Erstellers.
Anzeige
AW: Dateiliste mit Dateieigenschaften Category
04.10.2020 23:31:38
Thomas
also das mit DSO fällt flach, da wir zu 10 arbeiten und ich in der Firma keine DSO dll installieren darf/kann.
Jetzt habe ich allerdings von dir in einem anderem Forum:
http://www.office-loesung.de/ftopic52412_0_0_asc.php
deine Beitrag gefunden. Und siehe da: ich kann die Infos auch so durch die Shell Abfrage bekommen.
Aber: wie der Kollege schon erwähnt hat, ist bei deinem Script als Pfad eine Constante eingegeben. Ich benötige aber einen variablen Pfad, da ich davor eine Filterung nach Jahrgang mache. Bei Dim bricht bekomme ich Fehler.
Außerdem benötige ich noch die Möglichekeit, Subfolders zu integrieren. Diese möchte ich mit einem Schalter true/false setzen um zu entscheiden mit oder ohne Subfolders.
Geht das irgendwie?
Gruß, Thomas
kannst mir auch gerne direkt per Mail schreiben tom (at) sickculture .de
Anzeige
AW: Dateiliste mit Dateieigenschaften Category
05.10.2020 10:42:21
Nepumuk
Hallo Thomas,
teste mal:
Option Explicit

Public Sub SelectFolder()
    Dim objFileDialog As FileDialog
    Dim strFolder As String
    Dim blnSubFolder As Boolean
    Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With objFileDialog
        .AllowMultiSelect = False
        .InitialFileName = "G:\Eigene Dateien\" ' Anpassen !!!
        If .Show Then
            strFolder = .SelectedItems(1) & "\"
            If MsgBox("Mit Unterordnern?", vbQuestion Or vbYesNo, "Abfrage") = vbYes Then
                blnSubFolder = True
            Else
                blnSubFolder = False
            End If
            Call GetFileProperties(strFolder, blnSubFolder)
        End If
    End With
    Set objFileDialog = Nothing
End Sub

Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
    Const PROPERTIES_COUNT As Long = 360
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objShell As Object, objFolder As Object
    Dim lngIndex As Long, lngColumn As Long, lngRow As Long
    Dim vntFileName As Variant
    Application.ScreenUpdating = False
    If pvblnSubFolders Then
        astrFolders = GetFolders(pvstrFolder)
    Else
        Redim astrFolders(0)
        astrFolders(0) = pvstrFolder
    End If
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CVar(pvstrFolder))
    Call Cells.Clear
    lngColumn = 1
    For lngIndex = 0 To PROPERTIES_COUNT
        Cells(1, lngColumn + lngIndex).Value = objFolder.GetDetailsOf(Empty, lngIndex)
    Next
    Rows(1).Font.Bold = True
    lngRow = 2
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
        For Each vntFileName In objFolder.Items
            For lngIndex = 0 To PROPERTIES_COUNT
                Cells(lngRow, lngColumn + lngIndex) = objFolder.GetDetailsOf(vntFileName, lngIndex)
            Next
            lngRow = lngRow + 1
        Next
    Next
    Columns.AutoFit
    Set objShell = Nothing
    Set objFolder = Nothing
    Application.ScreenUpdating = True
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As String()
    Dim astrFolders() As String
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    Redim Preserve astrFolders(ialngIndex1)
    astrFolders(ialngIndex1) = pvstrPath
    ialngIndex1 = 1
    ialngIndex2 = 1
    strPath = pvstrPath
    Do
        strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
                    Redim Preserve astrFolders(0 To ialngIndex1)
                    astrFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = astrFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    GetFolders = astrFolders
End Function

Die Ausgabe erfolgt in der aktiven Tabelle.
Gruß
Nepumuk
Anzeige
AW: Dateiliste mit Dateieigenschaften Category
05.10.2020 13:07:19
Thomas
du bist der Wahnsinn... also es funktioniert schon mal. Ich bekomme eine komplette List aller Dateien.
Rechnet aber eine Zeit.
Frage:
1. wo kann ich das Script abändern, wenn ich nur einige Infos benötige. Es wird ja pro File alle "360" Properties eingelesen und pro Spalte ausgegeben. Das ist to much und resourcenvernichtend.
2. Wenn ich nur XLSM Dokumente anzeigen möchte? Und Subfolders (also leere Ordner) als Pfad nicht ausgegeben werden sollen?
3. Kann ich den Dialog am Anfang durch eine Variable ersetzen? Also Info kommt von einem vorhergehendem Script der Startpfad und Subfolder true)
4. Wenn ich die Headline anschaue, ist das dieses Script 

For lngIndex = 0 To PROPERTIES_COUNT
Cells(1, lngColumn + lngIndex).Value = objFolder.GetDetailsOf(Empty, lngIndex)
Next
Rows(1).Font.Bold = True
D.h. wenn ich die benötigend Infos abfragen möchte, ist der Wert der Zelle in Row1 in _ deutscher Sprache der Wert, den ich weiter unten vntFileName eintragen kann 

For Each vntFileName In objFolder.Items
For lngIndex = 0 To PROPERTIES_COUNT
Cells(lngRow, lngColumn + lngIndex) = objFolder.GetDetailsOf(vntFileName,  _
lngIndex)
Next
lngRow = lngRow + 1
Next
Aber schon mal rießen Respekt. Hätte ich so nicht hinbekommen.
Anzeige
AW: Dateiliste mit Dateieigenschaften Category
05.10.2020 13:49:30
Nepumuk
Hallo Thomas,
ich habe es jetzt so abgeändert, dass
1. Nur .xlsm-Dateien ausgegeben werden.
2. Nur bestimmte Eigenschaften gelistet werden. Dazu musst du in dieser Zeile:
avntProperyIndex = Array(0, 3, 4, 5, 20) ' Anpassen !!!
Die laufende Nummer der Eigenschaft eintragen. Beachte, die Nummerierung beginnt mit 0. Gib einfach in Zelle A2 eine 0 ein und in Zelle B2 eine 1. Beide Zellen markieren und nach rechts ziehen. Dann kannst du die Nummer der Eigenschaft einfach ablesen.
3. Du musst die Prozedur GetFileProperties aus dem anderen Makro so aufrufen:
Call GetFileProperties(Ordnerpfad mit abschließenden \, True)
True für Subfolders.
Deine Nummer 4 verstehe ich nicht.
Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objShell As Object, objFolder As Object
    Dim ialngIndex As Long, lngColumn As Long, lngRow As Long
    Dim vntFileName As Variant, avntProperyIndex As Variant
    Application.ScreenUpdating = False
    avntProperyIndex = Array(0, 3, 4, 5, 20) ' Anpassen !!!
    If pvblnSubFolders Then
        astrFolders = GetFolders(pvstrFolder)
    Else
        Redim astrFolders(0)
        astrFolders(0) = pvstrFolder
    End If
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CVar(pvstrFolder))
    Call Cells.Clear
    lngColumn = 1
    For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
        Cells(1, lngColumn + ialngIndex).Value = _
            objFolder.GetDetailsOf(Empty, avntProperyIndex(ialngIndex))
    Next
    Rows(1).Font.Bold = True
    lngRow = 2
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
        For Each vntFileName In objFolder.Items
            If LCase$(Right$(vntFileName.Path, 5)) = ".xlsm" Then
                For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
                    Cells(lngRow, lngColumn + ialngIndex) = _
                        objFolder.GetDetailsOf(vntFileName, avntProperyIndex(ialngIndex))
                Next
                lngRow = lngRow + 1
            End If
        Next
    Next
    Columns.AutoFit
    Set objShell = Nothing
    Set objFolder = Nothing
    Application.ScreenUpdating = True
End Sub

Gruß
Nepumuk
Anzeige
AW: Dateiliste mit Dateieigenschaften Category
05.10.2020 14:29:35
Thomas
ich glaube Punkt vier hat sich erledigt durch das Array.
Ich danke dir recht herzlich. Werde es ausprobieren.
AW: Dateiliste mit Dateieigenschaften Category
05.10.2020 15:19:07
Thomas
Funktioniert!
Habe deine Codes zusammengefügt/aktualisiert und die Liste funktioniert. Habe beide Scripte gespeichert. Einmal um alle Infos auszulesen und eine mit bestimmten Werten, die ich weiterverarbeite. Werde dies mal in meinen bestehenden Workflow einbauen.
Danke nochmals
https://www.herber.de/bbs/user/140664.zip
AW: Dateiliste mit Dateieigenschaften Category
06.10.2020 12:59:58
Thomas
So, ich habe deinen Code mal in meine Tabelle eingefügt. Ich beginne eigentlich mit dieser Zeile: 
Private Sub GetFileProperties(pvstrFolder As String, pvblnSubFolders As Boolean)

ByVal kenn ich nicht (kommt anscheinend von der Auswahl)
Meine Info ist der Path aus einem Script zuvor, der variabel übergeben wird als String ohne "\" am Ende. Subfolder ist immer true.
Das Script läuft durch und bei der Function bricht er ab. 
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then

Kannst mir weiterhelfen?
'Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
Private Sub GetFileProperties(pvstrFolder As String, pvblnSubFolders As Boolean)
Dim astrFolders() As String
Dim ialngFolders As Long
Dim objShell As Object, objFolder As Object
Dim ialngIndex As Long, lngColumn As Long, lngRow As Long
Dim vntFileName As Variant, avntProperyIndex As Variant
'Application.ScreenUpdating = False
Application.ScreenUpdating = True
avntProperyIndex = Array(180, 0, 18, 22, 23, 143, 145, 177) ' Anpassen !!!
If pvblnSubFolders Then
astrFolders = GetFolders(pvstrFolder)
Else
ReDim astrFolders(0)
astrFolders(0) = pvstrFolder
End If
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(CVar(pvstrFolder))
'Call Cells.Clear
lngColumn = 2
For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
Cells(5, lngColumn + ialngIndex).Value = _
objFolder.GetDetailsOf(Empty, avntProperyIndex(ialngIndex))
Next
Rows(1).Font.Bold = True
lngRow = 6
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
For Each vntFileName In objFolder.Items
If LCase$(Right$(vntFileName.Path, 5)) = ".xlsm" Then
For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
Cells(lngRow, lngColumn + ialngIndex) = _
objFolder.GetDetailsOf(vntFileName, avntProperyIndex(ialngIndex))
Next
lngRow = lngRow + 1
End If
Next
Next
Columns.AutoFit
Set objShell = Nothing
Set objFolder = Nothing
Application.ScreenUpdating = True
End Sub
Private Function GetFolders(pvstrPath As String)
'Private Function GetFolders(pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
ReDim Preserve astrFolders(ialngIndex1)
astrFolders(ialngIndex1) = pvstrPath
ialngIndex1 = 1
ialngIndex2 = 1
strPath = pvstrPath '& "\"
Do
strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
Do Until strFolder = vbNullString
If strFolder  "." And strFolder  ".." Then
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
ReDim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function

Anzeige
AW: Dateiliste mit Dateieigenschaften Category
06.10.2020 13:06:34
Nepumuk
Hallo Thomas,
füge nach dieser Zeile:
avntProperyIndex = Array(180, 0, 18, 22, 23, 143, 145, 177) ' Anpassen !!!
folgende Zeile ein:
If Right$(pvstrFolder,1) "\" Then pvstrFolder = pvstrFolder & "\"
Gruß
Nepumuk
AW: Dateiliste mit Dateieigenschaften Category
06.10.2020 14:02:47
Thomas
Funzt... danke dir. Mal schauen, was das nächste Problem wird ;-)
AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 07:05:49
Thomas
jetzt habe ich in der Tat noch was gefunden:
in der Arbeit sitze ich an einem Win7 Rechner. Dort funktioniert alles. Das Feld des Pfad (also Ordner mit *.xslm) ist in ArrayNr. 180.
Zuhause am Win10 Rechner und File auf Desktop liegend, ist das Feld Pfad plötzlich in Array 195.
Das ist blöd, weil ich aus diesem Feld einen Hyperlink erstelle um direkt Zugriff zu haben. Das scheint tatsächlich ein Problem zu sein, ob Win10 oder Win7. Liegt das an der Operation Shell.Application ?
Anzeige
AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 09:51:56
Nepumuk
Hallo Thomas,
das liegt vor allen Dingen daran, in welcher Reihenfolge Programme installiert wurden. Denn bei der Installation werden die Eigenschaften angelegt. Das hätte ich gleich schreiben sollen. Du könntest, je nach Anmeldenamen in Windows unterscheiden:
Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objShell As Object, objFolder As Object
    Dim ialngIndex As Long, lngColumn As Long, lngRow As Long
    Dim vntFileName As Variant, avntProperyIndex As Variant
    Application.ScreenUpdating = False
    Select Case Environ$("USERNAME")
        Case "Nepumuk"
            avntProperyIndex = Array(195, 0, 18, 22, 23, 143, 145, 177)
        Case "Thomas"
            avntProperyIndex = Array(180, 0, 18, 22, 23, 143, 145, 177)
        Case Else
            Call MsgBox("Unbekannter Benutzer.", vbCritical, "Programmabbruch")
            Exit Sub
    End Select
    If pvblnSubFolders Then
        astrFolders = GetFolders(pvstrFolder)
    Else
        Redim astrFolders(0)
        astrFolders(0) = pvstrFolder
    End If
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CVar(pvstrFolder))
    Call Cells.Clear
    lngColumn = 1
    For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
        Cells(1, lngColumn + ialngIndex).Value = _
            objFolder.GetDetailsOf(Empty, avntProperyIndex(ialngIndex))
    Next
    Rows(1).Font.Bold = True
    lngRow = 2
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
        For Each vntFileName In objFolder.Items
            If LCase$(Right$(vntFileName.Path, 5)) = ".xlsm" Then
                For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
                    Cells(lngRow, lngColumn + ialngIndex) = _
                        objFolder.GetDetailsOf(vntFileName, avntProperyIndex(ialngIndex))
                Next
                lngRow = lngRow + 1
            End If
        Next
    Next
    Columns.AutoFit
    Set objShell = Nothing
    Set objFolder = Nothing
    Application.ScreenUpdating = True
End Sub

Gruß
Nepumuk
Anzeige
AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 10:27:35
Thomas
danke, das ist zu umständlich. Wir sind mindestens 10 Personen mit 10 versch. PCs.
gibts im objShell nicht nicht die function .Self.Path? Also eine Variable, die mir den Dateinamen mit Pfad ausgibt und eine Variable, mit deren Dateinamen.xlsm (.Self.name)?
Die Keywords, Erstelldatum, letzter Zugriff und 0 Filename wird übernommen, aber ob das dann in Zukunft bei den anderen PCs auch der Fall ist, weiß ich nicht. Getestet hab ich es jetzt in der Arbeit am Arbeitsplatz und zuhause. Zuhause ist Excel 2013 auf Win10, in der Arbeit Excel 2010 auf Win7. Die Makros laufen alle. Nur eben die Array Ausgabe zerhaut es mir.
Anzeige
AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 10:39:47
Nepumuk
Hallo Thomas,
ja das geht. Ich kann den Pfad und den Namen aus vntFile holen:
Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objShell As Object, objFolder As Object
    Dim ialngIndex As Long, lngColumn As Long, lngRow As Long
    Dim vntFile As Variant, avntProperyIndex As Variant
    Application.ScreenUpdating = False
    avntProperyIndex = Array(18, 22, 23, 143, 145, 177)
    If pvblnSubFolders Then
        astrFolders = GetFolders(pvstrFolder)
    Else
        Redim astrFolders(0)
        astrFolders(0) = pvstrFolder
    End If
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CVar(pvstrFolder))
    Call Cells.Clear
    lngColumn = 3
    Cells(1, 1).Value = "Pfad"
    Cells(1, 2).Value = "Name"
    For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
        Cells(1, lngColumn + ialngIndex).Value = _
            objFolder.GetDetailsOf(Empty, avntProperyIndex(ialngIndex))
    Next
    Rows(1).Font.Bold = True
    lngRow = 2
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
        For Each vntFile In objFolder.Items
            If LCase$(Right$(vntFile.Path, 5)) = ".xlsm" Then
                Cells(lngRow, 1).Value = vntFile.Path
                Cells(lngRow, 2).Value = vntFile.Name
                For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
                    Cells(lngRow, lngColumn + ialngIndex).Value = _
                        objFolder.GetDetailsOf(vntFile, avntProperyIndex(ialngIndex))
                Next
                lngRow = lngRow + 1
            End If
        Next
    Next
    Columns.AutoFit
    Set objShell = Nothing
    Set objFolder = Nothing
    Application.ScreenUpdating = True
End Sub

Gruß
Nepumuk
AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 11:30:50
Thomas
danke, schau ich mir an.
du hast diese Zeilen eingefügt 
lngColumn = 3
Cells(1, 1).Value = "Pfad"
Cells(1, 2).Value = "Name"


Cells(lngRow, 1).Value = vntFile.Path
Cells(lngRow, 2).Value = vntFile.Name

AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 11:52:28
Thomas
Dass
Dim vntFileName As Variant
nun
Dim vntFile As Variant
heißt, ist doch egal?
AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 12:00:54
max.kaffl@gmx.de
Hallo Thomas,
na ja, vntFile ist ein Objekt und kein Name. Daher die Änderung.
Gruß
Nepumuk
AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 12:05:35
Thomas
OK? D.h. der Rest funktioniert aber trotzdem, dass ich z.B. Author, Keywords, ect. abfragen kann? Dann baue ich das mal um und teste. Vielen herzlichen Dank.
Kann man das ganze Script performancemässig noch schneller machen? das Einlesen dauert schon eine Zeit. Wenn nicht, auch kein Problem... Hast mir schon sehr weit weitergeholfen.
AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 12:11:29
Nepumuk
Hallo Thomas,
ich könnte mit einem Array arbeiten, das würde aber nur ein paar Millisekunden sparen. Da lohnt sich der Aufwand nicht. Die meiste Zeit benötigt das Shell-Objekt und daran kann ich nichts ändern.
Gruß
Nepumuk
AW: Dateiliste mit Dateieigenschaften Category
07.10.2020 13:37:11
Thomas
Ok... also ich habe das Script eingebaut und was soll ich sagen: es tut, was es tuen soll. Danke
AW: Dateiliste mit Dateieigenschaften Category
08.10.2020 11:10:42
Thomas
also ich habe die Tabelle nun nach meinen Wünschen hinbekommen und konnte meine Ordner einlesen. Super - funktioniert.
Jetzt soll nach dem Einlesen eine Userform mit Suchfunktion aufpoppen. Ich habe diese bereits soweit in Griff und möchte diese nun pimpen. Im Anhand mal eine Beispieldatei.
Ich stoße aber auf folgendes Problem:
Ich kann im Suchfeld nach allem Möglichen suchen. Es wird in der Listbox auch danach über alle Zeilen/Spalten gesucht. Das Script fand ich bei herber.de. Super! Daneben habe ich eine Combobox die Anfangs leer ist und mir alle Einträge in der Listbox anzeigtt. Soweit so gut. Nun habe ich zwei "Filter" in der Combobox, die mir nach AUFTRAG und OHNE ABNR sucht und dabei einen Autofilter auf der SEARCH Tabelle setzt. Macht sie auch, aber die Filelist zeigt bei OHNE ABNR noch die erste Zeile von AUFTRAG an und unter AUFTRAG taucht OHNE ABNR auf? Obwohl ich nach der Filtersetzung nochmals die Liste initialisiere. Also neu einlese.
Desweiteren hätte ich gerne noch die Möglichkeit, dass beim Anklicken der SingleSelect Listbox die Zeile im Tabellenblatt Search angezeigt wird. Also ein GoTo Row Befehl und ggf. diese in einer andere Farbe markiert. Wenn ich allerdings wieder einen anderen anklicke, soll der zuvor ausgewählte wieder ohne Füllung sein.
Und last but not least: bei Übernehmen, nur die Einträge aus der Listbox auf Search Result anzeigen, wobei dann die komplette Zeile aus dem Tabellenblatt Search kopiert werden soll und nicht nur der Bereich der Listbox mit den 8 Feldern.
Ich werde später noch bei anklicken der Werte in der Listbox diese in der Userform in Textboxen anzeigen lassen.
Ich weiß, das ist einiges, aber ich bin halt nur ein Copy and modify Mensch was den VBA Code angeht. Bin ja schon froh, diese komplexe Funktionen verstanden zu haben und zum Laufen bekam.
https://www.herber.de/bbs/user/140725.xlsm
AW: Dateiliste mit Dateieigenschaften Category
09.10.2020 12:22:58
Thomas
also ich komme nicht ganz weiter. Mein Suchfeld tut, was es tun soll. Aber die Option mit der ComboBox bekomme ich nicht hin. Es soll quasi im Listenfeld nur die Einträge aus der Tabelle Search angezeigt werden, die AUFTRAG oder OHNE ABNR haben. Wenn leer alle Einträge aus der Tabelle.
Irgendwo habe ich da einen Denkfehler. Ich habe die Scripte aus zwei Beispielen zusammengefügt.
Die Suche im Textfeld zeigt auf der gesamten Liste nur den Wert an, der irgendwo auf der Liste vorkommt. Das ist richtig.
Später würde ich ggf. noch zusätzliche Testboxen Suchfelder einbauen, um z.B. nur nach Spalte B und C zu suchen. Also nach den Auftragsnummern.
Und wie müsste ich mein Script erweitern, dass er mir nach einem OK Button direkt zur Zeile X auf Search springt?
Anbei meine ersten Versuche.
https://www.herber.de/bbs/user/140762.xlsm
AW: Dateiliste mit Dateieigenschaften Category
09.10.2020 13:37:32
Thomas
ich habe es hinbekommen. 
Private Sub ComboBox1_Change()
Application.EnableEvents = False
ListBox1.Clear
With Sheets("Search")
zeile = 5
Do
Zeichenkette = ""
If Me.ComboBox1 = .Cells(zeile, 5) Or Me.ComboBox1 = "" Then
For i = 1 To 9
Zeichenkette = Zeichenkette & .Cells(zeile, i) & "#"
Next i
If InStr(1, UCase(Zeichenkette), UCase(Me.TextBox1)) > 0 Then
ListBox1.AddItem .Cells(zeile, 9)
lngAnzahl = ListBox1.ListCount
ListBox1.List(lngAnzahl - 1, 1) = .Cells(zeile, 10)
ListBox1.List(lngAnzahl - 1, 2) = .Cells(zeile, 11)
ListBox1.List(lngAnzahl - 1, 3) = .Cells(zeile, 12)
ListBox1.List(lngAnzahl - 1, 4) = .Cells(zeile, 4)
ListBox1.List(lngAnzahl - 1, 5) = .Cells(zeile, 5)
ListBox1.List(lngAnzahl - 1, 6) = .Cells(zeile, 17)
ListBox1.List(lngAnzahl - 1, 7) = .Cells(zeile, 16)
ListBox1.List(lngAnzahl - 1, 8) = .Cells(zeile, 2)
ListBox1.List(lngAnzahl - 1, 9) = zeile
End If
End If
zeile = zeile + 1
Loop Until IsEmpty(.Cells(zeile, 2))
End With
Application.EnableEvents = True
End Sub
Private Sub CommandButton2_Click()
Application.EnableEvents = False
'Speichern in Listbox
ListBox1.List(ListBox1.ListIndex, 1) = TextBox2
ListBox1.List(ListBox1.ListIndex, 1) = TextBox3
ListBox1.List(ListBox1.ListIndex, 2) = TextBox4
ListBox1.List(ListBox1.ListIndex, 3) = TextBox5
'Speichern in Tabell
With Sheets("Search")
zeile = ListBox1.List(ListBox1.ListIndex, 9)
.Cells(zeile, 1) = Me.TextBox2
.Cells(zeile, 2) = Me.TextBox3
.Cells(zeile, 3) = Me.TextBox4
.Cells(zeile, 4) = Me.TextBox5
End With
Application.EnableEvents = True
End Sub
Private Sub ListBox1_Click() 'Übergabe in Textboxen
TextBox2 = ListBox1.List(ListBox1.ListIndex, 0)
TextBox3 = ListBox1.List(ListBox1.ListIndex, 1)
TextBox4 = ListBox1.List(ListBox1.ListIndex, 2)
TextBox5 = ListBox1.List(ListBox1.ListIndex, 3)
End Sub
Private Sub TextBox1_Change()
Application.EnableEvents = False
ListBox1.Clear
With Sheets("Search")
zeile = 5
Do
Zeichenkette = ""
If Me.ComboBox1 = .Cells(zeile, 5) Or Me.ComboBox1 = "" Then
For i = 1 To 9
Zeichenkette = Zeichenkette & .Cells(zeile, i) & "#"
Next i
If InStr(1, UCase(Zeichenkette), UCase(Me.TextBox1)) > 0 Then
ListBox1.AddItem .Cells(zeile, 9)
lngAnzahl = ListBox1.ListCount
ListBox1.List(lngAnzahl - 1, 1) = .Cells(zeile, 10)
ListBox1.List(lngAnzahl - 1, 2) = .Cells(zeile, 11)
ListBox1.List(lngAnzahl - 1, 3) = .Cells(zeile, 12)
ListBox1.List(lngAnzahl - 1, 4) = .Cells(zeile, 4)
ListBox1.List(lngAnzahl - 1, 5) = .Cells(zeile, 5)
ListBox1.List(lngAnzahl - 1, 6) = .Cells(zeile, 17)
ListBox1.List(lngAnzahl - 1, 7) = .Cells(zeile, 16)
ListBox1.List(lngAnzahl - 1, 8) = .Cells(zeile, 2)
ListBox1.List(lngAnzahl - 1, 9) = zeile
End If
End If
zeile = zeile + 1
Loop Until IsEmpty(.Cells(zeile, 2))
End With
Application.EnableEvents = True
End Sub
Private Sub UserForm_Initialize()
With Me.ListBox1
.ColumnCount = 10
.ColumnWidths = "50;60;150;250;60;50;40;40;50;50"
.Font.Size = 8
'     .BackColor = Sheets("Search").Range("A1").Interior.Color
'     .MultiSelect = fmMultiSelectSingle 'fmMultiSelectMulti
End With
With Sheets("Search")
zeile = 5
Do
ListBox1.AddItem .Cells(zeile, 9)
lngAnzahl = ListBox1.ListCount
ListBox1.List(lngAnzahl - 1, 1) = .Cells(zeile, 10)
ListBox1.List(lngAnzahl - 1, 2) = .Cells(zeile, 11)
ListBox1.List(lngAnzahl - 1, 3) = .Cells(zeile, 12)
ListBox1.List(lngAnzahl - 1, 4) = .Cells(zeile, 4)
ListBox1.List(lngAnzahl - 1, 5) = .Cells(zeile, 5)
ListBox1.List(lngAnzahl - 1, 6) = .Cells(zeile, 17)
ListBox1.List(lngAnzahl - 1, 7) = .Cells(zeile, 16)
ListBox1.List(lngAnzahl - 1, 8) = .Cells(zeile, 2)
ListBox1.List(lngAnzahl - 1, 9) = zeile
zeile = zeile + 1
Loop Until IsEmpty(.Cells(zeile, 2))
End With
Me.ComboBox1.AddItem "AUFTRAG"
Me.ComboBox1.AddItem "OHNE ABNR"
End Sub
Selektion funktioniert schon mal nach der ComboBox

Links zu Excel-Dialogen

ListBox TextBox

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige