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

Excel Dateien aus Ordner nach Änderungsdatum abarbeiten

Excel Dateien aus Ordner nach Änderungsdatum abarbeiten
22.10.2019 09:37:59
Sancho
Hallo,
folgendes Problem:
ich habe ein Makro, das folgendes macht:
1) Anwender wählt den Quellordner aus
2) Anwender wählt den Zielordner aus
3) Alle Dateien im Quellordner werden aktualisiert (dabei wird auf ein Excel Addin zugegriffen) und wenn in gewissen Zellen Zielwerte überschritten werden, werden die Tabellenblätter als PDF exportiert.
Das Marko läuft seit Jahren problemlos, nun gibt es aber einen Änderungswunsch:
Derzeit werden die Daten aus dem Quellordner in alphabetischer Reihenfolge abgearbeitet, es wäre aber besser wenn die Dateien nach den Änderungsdatum (aufsteigend) abgearbeitet würden.
So schaut der VBA Code derzeit aus:

Public Sub Update_And_PrintPDF(control As IRibbonControl)
Dim strVerzeichnis As String
Dim ZielVerzeichnis As String
Dim druckVerzeichnis As String
Dim StrDatei As String
Dim StrTyp As String
Dim Dateiname As String
Dim count As Integer
Dim countprint As Integer
Dim Anzahl As Integer
Dim fso As New Scripting.FileSystemObject
'Dim name As String
StrTyp = "*.xls*"
count = 0
countprint = 0
Anzahl = 0
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.AllowMultiSelect = False
.Title = "Bitte Quellordner auswählen"
.InitialFileName = ""
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "Auswählen"
If .Show = -1 Then
strVerzeichnis = .SelectedItems(1)
Else: MsgBox "Kein Ordner ausgewählt! Prozess wird abgebrochen."
Exit Sub
End If
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.AllowMultiSelect = False
.Title = "Bitte Zielordner auswählen"
.InitialFileName = ""
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "Auswählen"
If .Show = -1 Then
ZielVerzeichnis = .SelectedItems(1)
Else: MsgBox "Kein Ordner ausgewählt! Prozess wird abgebrochen."
Exit Sub
End If
End With
strVerzeichnis = strVerzeichnis & "\"
StrDatei = Dir(strVerzeichnis & StrTyp, vbDirectory)
Do While StrDatei  ""
Anzahl = Anzahl + 1
StrDatei = Dir
Loop
Dateiname = Dir(strVerzeichnis & StrTyp)
Do While Dateiname  ""
count = count + 1
Application.StatusBar = "Update in progress. File " & count & " of " & Anzahl
Application.ScreenUpdating = False
Workbooks.Open Filename:=strVerzeichnis & Dateiname
Dim i As Integer
For i = 1 To Sheets.count Step 1
Sheets(i).Activate
Application.Run ("ImportWorksheet")
Next i
If Sheets("OPI_Ges").Cells(8, 2).Value = "EUR" Then
If Sheets("OPI_Ges").Cells(27, 9).Value > 40 And Sheets("OPI_Ges").Cells(27, 9). _
Value  100 Then
Sheets(Array("OPI_Ges", "KFR_KZ_Ges", "BIL_Ges")).Select
Sheets("OPI_Ges").Activate
countprint = countprint + 1
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ZielVerzeichnis & "\" _
_
_
_
& fso.GetBaseName(ActiveWorkbook.name), Quality:=xlQualityStandard, IgnorePrintAreas:=False,    _
_
_
OpenAfterPublish:=False
End If
End If
Sheets(1).Activate
Excel.Application.DisplayAlerts = False
ActiveWorkbook.Close True
Dateiname = Dir
Loop
Application.StatusBar = "Update finished."
MsgBox count & " Excel files processed. " & countprint & " Excel files converted to PDF"
End Sub

Hat jemand eine Idee wie ich das hinbekommen, dass die Dateien eben in gewünschter Reihenfolge abgearbeitet werden?
Danke schonmal im Voraus!
Grüße
Martin

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel Dateien aus Ordner nach Änderungsdatum abarbeiten
22.10.2019 13:40:48
Rudi
Hallo Sancho,
Sub SanchoPansa()
Dim strPfad As String, strFile As String
Dim objFiles As Object, oOBJ, arrFiles()
Dim n As Integer, a As Integer
Dim wkb As Workbook
'Ordner ausw?hlen
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
strPfad = .SelectedItems(1) 'Ordner
End If
End With
If Len(strPfad) Then
Set objFiles = CreateObject("scripting.dictionary")
strPfad = strPfad & "\"
'Dateiname und ?nderungsdatum einlesen
strFile = Dir(strPfad & "*.xls*")
Do While strFile  ""
objFiles(strFile) = FileDateTime(strPfad & strFile)
strFile = Dir
Loop
If objFiles.Count Then  'Dateien gefunden, in Array packen
ReDim arrFiles(1 To objFiles.Count, 1 To 2)
For Each oOBJ In objFiles
n = n + 1
arrFiles(n, 1) = CDate(objFiles(oOBJ))
arrFiles(n, 2) = oOBJ
Next oOBJ
Call QuickSort2(arrFiles) 'Array nach Datum sortieren
Else
MsgBox "nix gefunden!", , "gebe bekannt..."
Exit Sub
End If
'Dateien abarbeiten, j?ngste zuerst
For a = UBound(arrFiles) To 1 Step -1
Set wkb = Workbooks.Open(strPfad & arrFiles(a, 2))
'hier Code zu Behandlung der Dateien
wkb.Close False
Next a
End If
End Sub
Sub QuickSort2(ByRef DasArray, Optional ErsteZeile, Optional LetzteZeile)
On Error Resume Next
Dim UnterGrenze As Long, OberGrenze As Long, aktuelleSpalte As Long
Dim AktuellerWert, GemerkterWert As Variant
If IsMissing(ErsteZeile) Then
ErsteZeile = LBound(DasArray)
End If
If IsMissing(LetzteZeile) Then
LetzteZeile = UBound(DasArray)
End If
UnterGrenze = ErsteZeile
OberGrenze = LetzteZeile
AktuellerWert = DasArray((ErsteZeile + LetzteZeile) / 2, 1)
Do While (UnterGrenze  AktuellerWert And OberGrenze > ErsteZeile)
OberGrenze = OberGrenze - 1
Loop
If (UnterGrenze  ErsteZeile) Then Call QuickSort2(DasArray, ErsteZeile, OberGrenze)
If (UnterGrenze 

Gruß
Alonso
Anzeige
AW: Excel Dateien aus Ordner nach Änderungsdatum abarbeiten
22.10.2019 13:46:16
Nepumuk
Hallo Sancho,
würde ich so machen:
Option Explicit

Public Sub Update_And_PrintPDF(control As IRibbonControl)
    
    Const StrTyp As String = "*.xls*"
    
    Dim strVerzeichnis As String
    Dim ZielVerzeichnis As String
    Dim count As Long
    Dim countprint As Long
    Dim Anzahl As Long
    Dim lngIndex As Long
    Dim objWorkbook As Workbook
    Dim objWorksheet As Worksheet
    Dim objSortedList As Object
    Dim objFSO As Scripting.FileSystemObject
    Dim objFile As File
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .AllowMultiSelect = False
        .Title = "Bitte Quellordner auswählen"
        .InitialFileName = ""
        .InitialView = msoFileDialogViewThumbnail
        .ButtonName = "Auswählen"
        If .Show = -1 Then
            strVerzeichnis = .SelectedItems(1) & "\"
        Else
            MsgBox "Kein Ordner ausgewählt! Prozess wird abgebrochen."
            Exit Sub
        End If
    End With
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .AllowMultiSelect = False
        .Title = "Bitte Zielordner auswählen"
        .InitialFileName = ""
        .InitialView = msoFileDialogViewThumbnail
        .ButtonName = "Auswählen"
        If .Show = -1 Then
            ZielVerzeichnis = .SelectedItems(1) & "\"
        Else
            MsgBox "Kein Ordner ausgewählt! Prozess wird abgebrochen."
            Exit Sub
        End If
    End With
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set objSortedList = CreateObject(Class:="System.Collections.SortedList")
    Set objFSO = New Scripting.FileSystemObject
    
    For Each objFile In objFSO.GetFolder(strVerzeichnis).Files
        Anzahl = Anzahl + 1
        Call objSortedList.Add(CStr(Clng(objFile.DateLastModified)) & Format$(Anzahl, "0000"), objFile.Path)
    Next
    
    For lngIndex = 0 To objSortedList.count - 1
        
        count = count + 1
        
        Application.StatusBar = "Update in progress. File " & count & " of " & Anzahl
        
        Set objWorkbook = Workbooks.Open(Filename:=objSortedList.GetByIndex(lngIndex))
        
        For Each objWorksheet In objWorkbook.Worksheets
            objWorksheet.Activate
            Application.Run "ImportWorksheet"
        Next
        
        If objWorkbook.Worksheets("OPI_Ges").Cells(8, 2).Value = "EUR" Then
            If objWorkbook.Worksheets("OPI_Ges").Cells(27, 9).Value > 40 And _
                objWorkbook.Worksheets("OPI_Ges").Cells(27, 9).Value < 100 Then
                objWorkbook.Worksheets(Array("OPI_Ges", "KFR_KZ_Ges")).Select
                countprint = countprint + 1
                objWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ZielVerzeichnis & "\" & _
                    objFSO.GetBaseName(objWorkbook.Name), Quality:=xlQualityStandard, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False
            ElseIf objWorkbook.Worksheets("OPI_Ges").Cells(27, 9).Value > 100 Then
                objWorkbook.Worksheets(Array("OPI_Ges", "KFR_KZ_Ges", "BIL_Ges")).Select
                countprint = countprint + 1
                objWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ZielVerzeichnis & "\" & _
                    objFSO.GetBaseName(objWorkbook.Name), Quality:=xlQualityStandard, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False
            End If
        End If
        
        objWorkbook.Worksheets(1).Activate
        
        objWorkbook.Close True
        
    Next
    
    Set objFSO = Nothing
    Set objSortedList = Nothing
    
    With Application
        .StatusBar = "Update finished."
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
    MsgBox count & " Excel files processed. " & countprint & " Excel files converted to PDF"
    
End Sub

Gruß
Nepumuk
Anzeige
AW: Excel Dateien aus Ordner nach Änderungsdatum abarbeiten
22.10.2019 14:32:27
Nepumuk
Hallo,
ich noch mal. Ändere diese Zeile:
Call objSortedList.Add(CStr(Clng(objFile.DateLastModified)) & Format$(Anzahl, "0000"), objFile.Path)
so:
Call objSortedList.Add(CStr(CDbl(objFile.DateLastModified)) & Format$(Anzahl, "0000"), objFile.Path)
ich hab nämlich die Uhrzeit vergessen.
Gruß
Nepumuk

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige