Absenzenspiegel erstellen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Abwesenheiten_übernehmen() Dim aktMitarbeiter As String Dim anfDatum As Date Dim endDatum As Date Dim letzteSpalteZ As Long Dim letzteZeileQ As Long Dim letzteZeileZ As Long Dim maxDatum As Date Dim minDatum As Date Dim spalteZ As Long Dim wb As Workbook Dim wsQ As Worksheet ' Quelle (Tabelle1) Dim wsZ As Worksheet ' Ziel (Tabelle2) Dim zeileQ As Long Dim zeileZ As Long Set wb = ThisWorkbook Set wsQ = wb.Worksheets("Tabelle1") Set wsZ = wb.Worksheets("Tabelle2") letzteZeileZ = wsZ.Cells(wsZ.Rows.Count, "B").End(xlUp).Row letzteSpalteZ = wsZ.Cells(9, wsZ.Columns.Count).End(xlToLeft).Column ' Bisherige Farben und x-Werte löschen If letzteZeileZ > 9 And letzteSpalteZ > 2 Then With wsZ.Cells(10, "B").Resize(letzteZeileZ - 9, letzteSpalteZ - 1) .Interior.Pattern = xlNone .ClearContents End With End If minDatum = wsZ.Range("C9") maxDatum = wsZ.Cells(9, letzteSpalteZ) letzteZeileQ = wsQ.Cells(wsQ.Rows.Count, "A").End(xlUp).Row zeileZ = 9 For zeileQ = 2 To letzteZeileQ If wsQ.Cells(zeileQ, "A") aktMitarbeiter Then ' Wechsel des Mitarbeiters zeileZ = zeileZ + 1 aktMitarbeiter = wsQ.Cells(zeileQ, "A") wsZ.Cells(zeileZ, "B") = aktMitarbeiter End If If Not IsEmpty(wsQ.Cells(zeileQ, "C")) And _ Not IsEmpty(wsQ.Cells(zeileQ, "D")) Then anfDatum = wsQ.Cells(zeileQ, "C") endDatum = wsQ.Cells(zeileQ, "D") For spalteZ = 3 To letzteSpalteZ If anfDatum

Hallo Hajo, hallo Richi,
@Hajo:
bei dem "noch offen" muss es sich um ein Versehen handeln. Ich weiss nicht, wie das zustande gekommen ist.
@Richi:
Ich habe versucht das Programm zu beschleunigen. Es ist mir aber nur gelungen, es etwa 10% schneller zu machen, ich hatte auf mehr gehofft.
Hier die neue Version:

Sub Abwesenheiten_übernehmen()
Dim aktMitarbeiter As String
Dim anfDatum As Date
Dim datum As Date
Dim dauer As Single
Dim endDatum As Date
Dim letzteSpalteZ As Long
Dim letzteZeileQ As Long
Dim letzteZeileZ As Long
Dim maxDatum As Date
Dim minDatum As Date
Dim spalteZ As Long
Dim wb As Workbook
Dim wsQ As Worksheet ' Quelle (Tabelle1)
Dim wsZ As Worksheet ' Ziel (Tabelle2)
Dim zeileQ As Long
Dim zeileZ As Long
dauer = Timer
Set wb = ThisWorkbook
Set wsQ = wb.Worksheets("Tabelle1")
Set wsZ = wb.Worksheets("Tabelle2")
letzteZeileZ = wsZ.Cells(wsZ.Rows.Count, "B").End(xlUp).Row
letzteSpalteZ = wsZ.Cells(9, wsZ.Columns.Count).End(xlToLeft).Column
' Bisherige Farben und x-Werte löschen
If letzteZeileZ > 9 And letzteSpalteZ > 2 Then
With wsZ.Cells(10, "B").Resize(letzteZeileZ - 9, letzteSpalteZ - 1)
.Interior.Pattern = xlNone
.ClearContents
End With
End If
minDatum = wsZ.Range("C9")
maxDatum = wsZ.Cells(9, letzteSpalteZ)
letzteZeileQ = wsQ.Cells(wsQ.Rows.Count, "A").End(xlUp).Row
zeileZ = 9
For zeileQ = 2 To letzteZeileQ
If wsQ.Cells(zeileQ, "A")  aktMitarbeiter Then
' Wechsel des Mitarbeiters
zeileZ = zeileZ + 1
aktMitarbeiter = wsQ.Cells(zeileQ, "A")
wsZ.Cells(zeileZ, "B") = aktMitarbeiter
End If
If Not IsEmpty(wsQ.Cells(zeileQ, "C")) And _
Not IsEmpty(wsQ.Cells(zeileQ, "D")) Then
anfDatum = WorksheetFunction.Max(wsQ.Cells(zeileQ, "C"), minDatum)
endDatum = WorksheetFunction.Min(wsQ.Cells(zeileQ, "D"), maxDatum)
If anfDatum

Viele Grüße
Dieter

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread