Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1068to1072
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
Inhaltsverzeichnis

Löschmakro

Löschmakro
20.04.2009 16:13:05
Anne
Hallo allerseits,
auf unserem Server werden in einem Ordner(Tagesbilanz) und dessen Unterordner Sicherungskopien
diverser xls. Dateien abgelegt. Am Ende des Tages werden diese, nach dem die Originaldateien in einem
anderen Ordner archiviert wurden, allesamt gelöscht.
Kann man ein Makro erstellen, welches den Löschvorgang per Button beschleunigt?
Beispiel:
Im Ordner "Tagesbilanz" befinden sich etwa 70 Unterordner und in diesen insgesamt ca 1500 .xls Sicherungskopien, allerdings gemischt mit .doc und .jpg Dateien(diese sollten aber bestehen bleiben).
Es sollen einfach alle .xls Dateien möglichst in einem Rutsch gelöscht werden.
Hoffentlich hat jemand von euch eine Lösung
LG
Anne

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Löschmakro
20.04.2009 17:35:14
Tino
Hallo,
teste mal diesen Code.
Aber wirklich erst mal nur testen, die Dateien werden komplett gelöscht. (kein Papierkorb)
Option Explicit
Dim FSO

Private Declare Function GetShortPathNameA Lib "kernel32" ( _
    ByVal lpszLongPath As String, _
    ByVal lpszShortPath As String, _
    ByVal cchBuffer As Long) As Long

Public Function ShortPath(ByRef Path As String) As String
  Dim n As Long
  ShortPath = Space$(256)
  n = GetShortPathNameA(Path, ShortPath, 255)
  ShortPath = Left$(ShortPath, n)
End Function

Private Sub GetSubFolders(MyAr, sPfad As String, LRow)
Dim FO, FU, F
Set FO = FSO.GetFolder(sPfad)
Set FU = FO.SubFolders

On Error GoTo goNext:
    For Each F In FU
        MyAr(LRow) = ShortPath(F.Path)
        MyAr(LRow) = IIf(Right$(MyAr(LRow), 1) = "\", MyAr(LRow), MyAr(LRow) & "\")
        LRow = LRow + 1
        GetSubFolders MyAr, F.Path, LRow
    Next

goNext:
End Sub

Sub KillExcelFiles()
Dim MyAr() As String
Dim LRow As Long
Dim strPfad As String

'Pfad anpassen ********************* 
strPfad = "C:\Test Ordner\Neuer Ordner\"

LRow = 0
Redim Preserve MyAr(LRow)

MyAr(LRow) = ShortPath(strPfad)
LRow = 1

Set FSO = CreateObject("Scripting.FileSystemObject")
GetSubFolders MyAr, strPfad, LRow


For LRow = Lbound(MyAr) To Ubound(MyAr)
 Kill MyAr(LRow) & "*.xls"
Next LRow

Set FSO = Nothing
End Sub


Gruß Tino

Anzeige
Korrektur!!
20.04.2009 17:41:03
Tino
Hallo,
da war durchs aufräumen noch ein Fehler entstanden.
Option Explicit
Dim FSO

Private Declare Function GetShortPathNameA Lib "kernel32" ( _
    ByVal lpszLongPath As String, _
    ByVal lpszShortPath As String, _
    ByVal cchBuffer As Long) As Long

Public Function ShortPath(ByRef Path As String) As String
  Dim n As Long
  ShortPath = Space$(256)
  n = GetShortPathNameA(Path, ShortPath, 255)
  ShortPath = Left$(ShortPath, n)
End Function

Private Sub GetSubFolders(MyAr, sPfad As String, LRow)
Dim FO, FU, F
Set FO = FSO.GetFolder(sPfad)
Set FU = FO.SubFolders

On Error GoTo goNext:
    For Each F In FU
        Redim Preserve MyAr(LRow)
        MyAr(LRow) = ShortPath(F.Path)
        MyAr(LRow) = IIf(Right$(MyAr(LRow), 1) = "\", MyAr(LRow), MyAr(LRow) & "\")
        LRow = LRow + 1
        GetSubFolders MyAr, F.Path, LRow
    Next

goNext:
End Sub

Sub KillExcelFiles()
Dim MyAr() As String
Dim LRow As Long
Dim strPfad As String

'Pfad anpassen ********************* 
strPfad = "J:\1 Forum\"

LRow = 0
Redim Preserve MyAr(LRow)

MyAr(LRow) = ShortPath(strPfad)
LRow = 1

Set FSO = CreateObject("Scripting.FileSystemObject")
GetSubFolders MyAr, strPfad, LRow

On Error Resume Next
For LRow = Lbound(MyAr) To Ubound(MyAr)
 Kill MyAr(LRow) & "*.xls"
Next LRow
On Error GoTo 0

Set FSO = Nothing
End Sub


Gruß Tino

Anzeige
AW: Korrektur!!
21.04.2009 07:07:21
Anne
Hi Tino,
vielen, vielen Dank! :-)
Hast 'nen armen Azubi sehr viel Arbeit erspart.
Eine Frage bzw. Bitte hätte ich noch. Bei der Menge zu löschender Dateien
vergeht ja ein bischen Zeit(2-3 Min). Kann man währen des Löschvorgangs
einen Hinweis einblenden mit der Info was gerade passiert?
z.B. "Der Ordner Tagesbilanz wird gerade bereinigt, haben Sie einen Moment
Geduld" und wenn die Sanduhr abgelaufen ist "Tagesbilanz bereinigt".
Vielen Dank
LG
Anne
Obwohl Du ja die Frage schon nach meiner Vorstellung beantwortest hast,
lasse ich diesen Beitrag bezüglich der zweiten Frage noch mal offen.
Anzeige
AW: Korrektur!!
21.04.2009 08:29:13
Tino
Hallo,
dies würde ich in etwa so machen, die Anzeige wird von einer Userform übernommen.
Pfad musst Du im Code wieder anpassen.
https://www.herber.de/bbs/user/61325.xls
Gruß Tino
Zusatzfrage
23.04.2009 09:37:14
Anne
Hallo Tino
noch einmal herzlichen Dank, funzt alles bestens.
Kann man eventuell das Löschen von *.jpg im Code
doch noch mit einbinden?
Vielen Dank
LG
Anne
AW: Löschmakro
23.04.2009 10:37:30
Dirk
Hallo Anne
dazu musst Du diesen Teil des Macro entsprechend aendern:
On Error Resume Next
For LRow = Lbound(MyAr) To Ubound(MyAr)
Kill MyAr(LRow) & "*.xls"
Kill MyAr(LRow) & "*.jpg"
Next LRow
On Error GoTo 0
Gruss
Dirk aus Dubai
Anzeige
...noch nicht ganz gelöst
23.04.2009 15:23:06
Anne
Hallo,
der Code läuft jetzt sauber durch, mit dem gewünschten Ergebnis, Danke.
Ein Problem gibt es aber doch noch, sobald der Löschvorgang gestartet wird,
öffnet sich die UserForm ohne Inhalt(quasi eine BlankoUserForm). Dies hindert zwar
den gesammten Ablauf nicht, der Sinn mit der Form ist ja gewesen, das eine
entsprechende Info gezeigt wird, über das was da gerade passiert.
Gibt es vielleicht eine Erklärung für das nicht Anzeigen des Vorgangs?
Ohne die Erweiterung funktioniert die UF einwandfrei.
LG
Anne
AW: ...noch nicht ganz gelöst
23.04.2009 16:42:59
Tino
Hallo Anne,
Die Sub müsste jetzt so aussehen.
Private Sub KillExcelFiles()
Dim MyAr() As String
Dim LRow As Long
Dim strPfad As String

'Pfad anpassen ********************* 
strPfad = "J:\1 Forum\"

LRow = 0
Redim Preserve MyAr(LRow)

MyAr(LRow) = strPfad
LRow = 1

Set FSO = CreateObject("Scripting.FileSystemObject")
GetSubFolders MyAr, strPfad, LRow

UserForm_Anzeige.Label1.Visible = True
UserForm_Anzeige.Label2.Visible = True
UserForm_Anzeige.Label3.Visible = True

On Error Resume Next
    For LRow = Lbound(MyAr) To Ubound(MyAr)
     strPfad = Left(MyAr(LRow), Len(MyAr(LRow)) - 1)
     UserForm_Anzeige.Label3.Caption = Right$(strPfad, Len(strPfad) - InStrRev(strPfad, "\"))
     UserForm_Anzeige.Repaint
     strPfad = ShortPath(MyAr(LRow))
     strPfad = IIf(Right$(strPfad, 1) = "\", strPfad, strPfad & "\")
     Kill ShortPath(MyAr(LRow)) & "*.xls"
     Kill ShortPath(MyAr(LRow)) & "*.jpg"
    Next LRow
On Error GoTo 0

Unload UserForm_Anzeige
MsgBox "Bereinigung ist abgeschlossen.", vbInformation, "Info"
Set FSO = Nothing
End Sub


Gruß Tino

Anzeige
Perfekt...vielen Dank! LG Anne owT
23.04.2009 19:20:19
Anne
.

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige