Leere Zeilen überspringen in Makro
15.12.2021 08:41:04
Patrick
UweD hatte mir vor einigen Tagen sehr weitergeholfen und mir einen VBA-Code zur Verfügung gestellt, der automatisiert Dateien kopiert und nach einem bestimmten Muster umbenenennt. Dabei wird folgender Code genutzt.
Option Explicit
Sub Umbenennen()
Dim Dlg As FileDialog, FSO As Object
Dim PfadAlt As String, PfadNeu As String, Datei, Anz As Long
Dim Ext As String, DatNeu As String
Dim Sp As Integer, Ze As Long, LR As Long
PfadAlt = "C:\"
Ext = ".pdf"
Sp = 5 'Spalte für den Dateinamen der PDFs
Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
Dlg.InitialFileName = PfadAlt
If Dlg.Show = True Then
PfadAlt = Dlg.SelectedItems(1) & "\"
PfadNeu = PfadAlt & "umgewandelt\"
If Dir(PfadNeu, vbDirectory) = "" Then
MkDir PfadNeu ' wenn Pfad nicht vorhanden, dann anlegen
End If
LR = Cells(Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
For Ze = 10 To LR
Datei = Cells(Ze, Sp)
If Dir(PfadAlt & Datei) "" Then 'Datei vorhanden
'neuer Dateiname
DatNeu = Cells(Ze, 2) & "." & Cells(Ze, 3) & "." & Cells(Ze, 4) & Ext
'umbenennen und kopieren
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.copyFile PfadAlt & Datei, PfadNeu & DatNeu
Anz = Anz + 1
'nochmal vorhanden?
If WorksheetFunction.CountIf(Cells(Ze + 1, Sp).Resize(LR - Ze + 1, 1), Datei) = 0 Then
'wenn letzte Kopie, dann erst löschen
FSO.deletefile PfadAlt & Datei
End If
Else
Exit Sub
End If
Next
Else
MsgBox "Es wurde kein Ordner zum Umbenennen von PDF-Dateien ausgewählt"
End If
MsgBox Anz & " Dateien umbenannt"
Set FSO = Nothing
End Sub
Viele Grüße
Patrick