AW: @yummi Frage bezüglich seines Codes
29.11.2017 14:52:40
arek
Hi yummi,
vielen Dank für deine Antwort! Ich habe nun folgenden Code, aber nachwievor das Problem, dass beim Start des Makros "keine Rückmeldung" leider kommt. Könntest du dir das nochmal anschauen bitte? Siehst du eine andere Möglichkeit wie man nur bestimmte Dateien durch das Makro ansprechen kann? Vielen Dank dir nochmal!
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:\Users\arek\Desktop\TEST\" 'Pfad, unter welchem die Stundenlisten liegen
Dateiname = Dir(Pfad & "*.xlsm")
Initialisiere 'Funktion Initialisiere siehe unten
On Error Resume Next
Set FoundCells = wksDest.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeConstants)
If Not FoundCells Is Nothing Then
wksDest.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeConstants).Value = ""
End If
On Error GoTo 0
arr = Array("Christof", "Thomas")
Do While Dateiname "" 'Durchlaufen der Stundenlisten
b = False
For Each na In arr
If InStr(1, Dateiname, "*" & na & "*_hours_booking*", vbTextCompare) Then
b = True
Exit For
End If
Next na
If b = True Then
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 llastr > 2000 Then 'Stundenlisten nur bis Zeile 2000 durchlaufen
llastr = 2000
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 "" Then
'Zeile kopieren und anschließender Übergang zur nächsten Stundenliste
wksDest.Cells(llastdest, 1).Value = wksdata.Cells(2, s).Value 'Belegdatum
wksDest.Cells(llastdest, 2).Value = wksdata.Cells(2, s).Value ' _
Buchungsdatum
wksDest.Cells(llastdest, 3).Value = wksdata.Cells(1, 1).Value ' _
Kostenstelle
wksDest.Cells(llastdest, 4).Value = wksdata.Cells(1, 3).Value ' _
Leistungsart
wksDest.Cells(llastdest, 6).Value = wksdata.Cells(z, 2).Value 'Projektname
wksDest.Cells(llastdest, 7).Value = wksdata.Cells(z, s).Value 'Menge
wksDest.Cells(llastdest, 8).Value = "H" 'ME
wksDest.Cells(llastdest, 9).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
End If
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("Tabelle1")
End If
End Function