Ich will alle Dateien in einem bestimmten Verzeichnis mit Excel in Tabellenform erfassen und auch noch die größe dieser Dateien in einer zweiten Spalte - geht das?
Bin für jeden Tipp dankbar!!!
Bin für jeden Tipp dankbar!!!
-------------------------------------------------------- mfg, GraFri'Verzeichnis selektieren, auslesen und in Tabelle schreiben
' -----------------------------------------------------------------------------------
' Dieser Bereich kann entfallen, wenn der Variable 'strLaufwerk'
' ein fester Wert zugewiesen wird.
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
' -----------------------------------------------------------------------------------
Private sngZ As Single
' Hauptprogramm
Sub Suchen()
Dim strLaufwerk As String, strDateien As String
' Erste Zeile, in der eine Eintragung erfolgt
sngZ = 2
' Alte Eintragungen löschen
Columns("A:E") = ""
' Den Variablen strLaufwerk und strDateien kann
' auch ein direkter Wert zugewiesen werden.
' Ersatz: ... = "C:\Eigene strDateien"
strLaufwerk = GetDirectory("Bitte einen Ordner wählen")
If strLaufwerk = "" Then Exit Sub
' Ersatz: strDateien = "*.*"
strDateien = InputBox("Nach welchen Dateien soll in" & _
Chr(10) & " " & strLaufwerk & Chr(10) & _
"gesucht werden (sng z.B. *.xls)?", _
"Dateityp", "*.*")
If strDateien = "" Then Exit Sub
Dateisuche strLaufwerk, strDateien
End Sub
Sub Dateisuche(strLaufwerk, strDateien)
Dim tmp, Wdhlg, strDateiname As String
On Error Resume Next
If Right(strLaufwerk, 1) <> "\" Then strLaufwerk = strLaufwerk + "\"
tmp = Dir(strLaufwerk & strDateien)
Do While Len(tmp)
strDateiname = strLaufwerk & tmp
Application.StatusBar = strDateiname
Cells(sngZ, 1).Select
Cells(sngZ, 1) = strLaufwerk & tmp 'Pfad
Cells(sngZ, 2) = FileLen(strLaufwerk & tmp) 'Größe
Cells(sngZ, 3) = FileDateTime(strLaufwerk & tmp) 'Datum/Zeit
Cells(sngZ, 4) = tmp 'nur Dateiname
sngZ = sngZ + 1
tmp = Dir()
Loop
tmp = Dir(strLaufwerk, vbDirectory)
Do While Len(tmp)
If (tmp <> ".") And (tmp <> "..") Then
If (GetAttr(strLaufwerk & tmp) And vbDirectory) = vbDirectory Then
Dateisuche strLaufwerk & tmp, strDateien
sngZ = sngZ - 1
Wdhlg = Dir(strLaufwerk, vbDirectory)
sngZ = sngZ + 1
Do While Wdhlg <> tmp
Wdhlg = Dir()
Loop
End If
End If
tmp = Dir()
Loop
On Error GoTo 0
Application.StatusBar = False
End Sub
'//Datei, DLG csv-Datei öffnen//
' Öffnen-Dialog aufrufen, Auswahl: csv-Dateien
Sub MachAuf()
Datei = Application.GetOpenFilename("CSV-Dateien (*.csv), *.csv")
If Datei <> "Falsch" Then Workbooks.Open Filename:=Datei
End Sub
'//Datei, Dateien verschieben//
Dim strZielordner As String
' Aufruf mit dem folgenden Makro
Sub VerschiebeDateien()
Dim strHerkunftsordner As String, strDateienSuchstring As String
strZielordner = "C:\Eigene Dateien\Test\"
strHerkunftsordner = "C:\Eigene Dateien"
strDateienSuchstring = "*.xls"
Call DateienSuchenKopierenLöschen(strHerkunftsordner, strDateienSuchstring)
End Sub
' Ist verantwortlich für das Durchsuchen des Ordners und das Kopieren der Dateien
Sub DateienSuchenKopierenLöschen(strHerkunftsordner, strDateienSuchstring)
Dim strTmp As String, strWdhlg, strDateiname As String
' On Error Resume Next
If Right(strHerkunftsordner, 1) <> "\" Then strHerkunftsordner = strHerkunftsordner + "\"
' Erste Suche mit Dir() muss das Argument Fullname enthalten, Platzhalter * und ? werden unterstützt
strTmp = Dir(strHerkunftsordner & strDateienSuchstring)
' solange den Vorgaben in strDateienSuchstring (z.B. *.xls)
' eine entsprechende Datei gefunden wird
Do While Len(strTmp)
strDateiname = strHerkunftsordner & strTmp
Application.StatusBar = strDateiname
FileCopy strHerkunftsordner & strTmp, strZielordner & strTmp
Kill strHerkunftsordner & strTmp
' Die nächste den Vorgaben in strDateienSuchstring (z.B. *.xls) entsprechende Datei wird ohne
' Argumente gesucht, Dir() gibt dann eine Null-Zeichenfolge ("") zurück, wenn keine weitere Datei gefunden wird.
strTmp = Dir()
Loop
' Hier wird der Herkunftsordner auf Unterordner abgefragt und, falls vorhanden, miteinbezogen..
' Das gibt dann Probleme, wenn der Zielordner ein Unterordner vom Herkunftsordner ist.
' strTmp = Dir(strHerkunftsordner, vbDirectory)
' Do While Len(strTmp)
' If (strTmp <> ".") And (strTmp <> "..") Then
' If (GetAttr(strHerkunftsordner & strTmp) And vbDirectory) = vbDirectory Then
' DateienSuchenKopierenLöschen strHerkunftsordner & strTmp, strDateienSuchstring
' strWdhlg = Dir(strHerkunftsordner, vbDirectory)
' Do While strWdhlg <> strTmp
' strWdhlg = Dir()
' Loop
' End If
' End If
' strTmp = Dir()
' Loop
' On Error GoTo 0
Application.StatusBar = False
End Sub
' Ruft das Dialogfeld zur Ordnerauswahl auf (deaktiviert)
Function GetDirectory(Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
With bInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
' Funktion mit "shell32.dll"
x = SHBrowseForFolder(bInfo)
path = Space$(512)
' Funktion mit "shell32.dll"
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
--------------------------------------------------------
vielen Dank für das ausführliche Makro, danach habe ich schon lange gesucht.
Wäre nett, wenn Du mir dazu ein paar Fragen (ganz kurz) beantworten könntest.
1. Ich möchte eine große Anzahl von Dateien einlesen. Daher ist
Application.StatusBar = strDateiname nicht sinnvoll.
Um eine ständige Bildschirmaktualisierung zu vermeiden habe ich den Befehl
Application.ScreenUpdating = False
am Anfang des Makros Sub Dateisuche(strLaufwerk, strDateien) eingefügt. Leider erfolgt dennoch eine sukzessive Bildschirmaktualisierung. Wie erreicht man es, dass erst nachdem alle Daten eingelesen wurden der Bildschirm aktualisiert wird?
2. Was bedeutet sng in der Zeile "gesucht werden (sng z.B. *.xls)?", _?
Gruß Rainer
Das mit 'Application.StatusBar' kann ohne weiteres weggelassen werden (kleien Spielerei).
Bildschirmaktualisierung:
Dies könnte man umgehen, indem man alle gewünschten Dateigrößen in ein Datenfeld einließt und diese bei Ende der Dateisuche auf einmal in das Tabellenblatt schreibt.
'sng' bedeutet:
Die Dateisuche wird nach verschiedenen Kriterien durchgeführt.
*.* ---> alle Dateien werden angezeigt
*.xls ---> nur Dateien mit Dateiändung xls(Excel-Dateien)
G*.txt ---> alle Textdateien, die mit 'G' beginnen
*Ber*.xls ---> alle Excel-Dateien, in denen Namen 'Ber' vorkommt
Falls weitere Fragen, bitte mailen.
mfg, GraFri