Nicht alle Dateien werden vom Makro erfasst
06.03.2018 12:14:38
arek
ich habe folgendes Makro entworfen, welches mir aus einem Ordner Stundenlisten auswertet bzw. zusammenfasst. Dieses läuft auch sehr gut, allerdings gibt es zwei Dateien in dem Ordner, wo keine Auswertung erfolgt, obwohl hier Stunden hinterlegt sind...Diese beiden Dateien sind genauso aufgebaut wie die anderen, doch läuft das Makro hier drüber, macht aber keine entsprechenden Eintragungen...
Kann mir da jemand weiterhelfen? Was könnten die Gründe dafür sein?
Option Explicit
Dim wkb As Workbook
Dim wksdata As Worksheet
Dim wksDest As Worksheet
Dim wkbData As Workbook
Sub Update_Button()
Dim llastr As Long
Dim ilasts As Integer
Dim z As Long
Dim s As Integer
Dim llastdest As Long
Dim Pfad As String
Dim Dateiname As String
Dim iRow As Long
Dim arr, na, b As Boolean
Dim FoundCells As Range
Pfad = "C:\Desktop\benutzer\arek\" 'Pfad, unter welchem die Stundenlisten liegen
Dateiname = Dir(Pfad & "*_hours__booking.xlsm")
Initialisiere 'Funktion Initialisiere siehe unten
On Error Resume Next
wksDest.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeConstants).Value = ""
On Error GoTo 0
Do While Dateiname "" 'Durchlaufen der Stundenlisten
Set wkbData = Workbooks.Open(Filename:=Pfad & Dateiname)
Set wksdata = wkbData.Sheets("Hours")
llastr = BestimmeLetzteZeile(wksdata, 2) 'letzte Zeile erstellen
ilasts = BestimmeLetzteSpalte(wksdata, 2) 'letzte Spalte bestimmen
llastdest = BestimmeLetzteZeile(wksDest, 1) + 1
If ilasts > 54 Then 'Stundenlisten nur bis Spalte 54 durchlaufen
ilasts = 54
End If
If llastr > 1500 Then 'Stundenlisten nur bis Zeile 1500 durchlaufen
llastr = 1500
End If
For z = 5 To llastr 'Alle Zeilen ab Zeile 5 werden durchlaufen
For s = 3 To ilasts 'Alle Spalten ab Spalte C werden durchlaufen
If wksdata.Cells(z, s).Value "" And wksdata.Cells(z, s).Value 0 Then
'Zeile kopieren und anschließender Übergang zur nächsten Stundenliste
wksDest.Cells(llastdest, 1).Value = wksdata.Cells(2, s).Value ' _
Kalenderwoche
wksDest.Cells(llastdest, 4).Value = wksdata.Cells(1, 1).Value ' _
Kostenstelle
wksDest.Cells(llastdest, 5).Value = wksdata.Cells(1, 3).Value ' _
Leistungsart
wksDest.Cells(llastdest, 7).Value = wksdata.Cells(z, 2).Value 'Projektname
wksDest.Cells(llastdest, 8).Value = wksdata.Cells(z, s).Value 'Menge
wksDest.Cells(llastdest, 9).Value = "H" 'ME
wksDest.Cells(llastdest, 10).Value = wksdata.Cells(1, 2).Value ' _
Personalnummer
llastdest = llastdest + 1
End If
Next s
Next z
wkbData.Close False
Set wksdata = Nothing
Set wkbData = Nothing
Dateiname = Dir() 'Automatische Auswahl der nächsten Datei
Loop
End Sub
Function BestimmeLetzteZeile(ByVal wks As Worksheet, ByVal s As Integer) As Long
BestimmeLetzteZeile = wks.Cells(wks.Rows.Count, s).End(xlUp).Row
End Function
Function BestimmeLetzteSpalte(ByVal wks As Worksheet, ByVal z As Long) As Integer
If wks.Cells(z, 1).Value "" Then
BestimmeLetzteSpalte = wks.Cells(z, wks.Columns.Count).End(xlToLeft).Column
Else
BestimmeLetzteSpalte = 1
End If
End Function
Function Initialisiere()
If wkb Is Nothing Then
Set wkb = ThisWorkbook
Set wksDest = wkb.Sheets("Overview")
End If
End Function