AW: Ganz großes Problem
29.08.2014 14:04:19
fcs
Hallo Falo,
hier ein Makro für die Übernahme der Tages-Daten in das Blatt für den lfd. Monat.
Beim Start des Makros müssen beide Dateien geöffnet sein.
Gruß
Franz
'Makro in einem allgemeinen Modul der Datei "lfd Monat.xls"
Sub DatenHolenAus_Stunden_Tag()
Dim Zeile_Q As Long
Dim ZeileMax As Long
Dim Zeile_Z As Long, Spalte_Z As Long, varDatum
Dim rngTreffer As Range, rngSuche As Range
Dim varPersNr_Z, varPersNr_Q
Dim wkbQuelle As Workbook, wksQuelle As Worksheet, strQuelle As String
Dim wkbZiel As Workbook, wksZiel As Worksheet
Set wkbZiel = ThisWorkbook
Set wksZiel = wkbZiel.Worksheets(1)
strQuelle = "Stunden Tag.xls" 'Name der Datei mit den Tages Daten
'prüfen, ob Datei schon geöffnet ist
For Each wkbQuelle In Application.Workbooks
If LCase(wkbQuelle.Name) = LCase(strQuelle) Then
Exit For
End If
Next
If wkbQuelle Is Nothing Then
MsgBox "Die Datei ""Stunden Tag.xls"" ist noch nicht geöffnet, " _
& "bitte Datei erst öffnen"
GoTo Beenden
End If
Set wksQuelle = wkbQuelle.Worksheets(1)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With wksQuelle
varDatum = wksQuelle.Range("A2").Value
If Not IsDate(varDatum) Then
MsgBox "Kein Datum in Zelle A2 von Blatt """ & wksQuelle.Name _
& """ in Datei " & wkbQuelle.Name
GoTo Beenden
End If
'letzte Zeile mit Daten in Spalte F
Zeile_Q = .Cells(.Rows.Count, 6).End(xlUp).Row
If Zeile_Q > 1 Then
'Suchbereich mit Personalnummern in Spalte F
Set rngSuche = .Range(.Cells(2, 6), .Cells(Zeile_Q, 6))
Else
'keine Daten in Stunden Tag
GoTo Beenden
End If
End With
With wksZiel
'Spalte mit Tag in "lfd Monat"
Spalte_Z = 3 + Day(varDatum)
ZeileMax = .Cells(.Rows.Count, 2).End(xlUp).Row 'letzte Zeile mit Personalnummer
'Zeilen in Ziel (lfd Monat) abarbeiten
For Zeile_Z = 7 To ZeileMax
'Pers.-Nr. in "lfd Monat"
varPersNr_Z = .Cells(Zeile_Z, 2).Value
'Pers.-Nr. in "Stunden Tag"
varPersNr_Q = Format(varPersNr_Z, "000000")
With wksQuelle
'PersonalNr in Spalte F suchen
Set rngTreffer = rngSuche.Find(what:=varPersNr_Q, LookIn:=xlValues, _
lookAt:=xlWhole)
If rngTreffer Is Nothing Then
'PersonalNr ist nicht vorhanden
Else
'Personal-Nr. ist vorhanden - Wert aus Palte J in lfdMonat eintragen
Zeile_Q = rngTreffer.Row
wksZiel.Cells(Zeile_Z, Spalte_Z).Value = .Cells(Zeile_Q, 10).Value
End If
End With
Next Zeile_Z
End With
Beenden:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set wkbZiel = Nothing: Set wksZiel = Nothing: Set wkbQuelle = Nothing: Set wksQuelle = _
Nothing
Set rngSuche = Nothing: Set rngTreffer = Nothing
End Sub