AW: Automatisiertes Aufgabenprotokoll
02.03.2018 13:38:43
MCO
Hallo Hans!
Da war noch einiges im Argen:
Formatierungen, Zellzuweisungen, etc.
Den Code hab ich auf die schnelle etwas übersichtlicher gekürzt, indem ich die Tab-Bezüge ausgeklammert habe, wirst du sehen. Geht auch noch mehr, aber das hab ich jetzt gespart.
Probier es mal aus....
Gruß, MCO
Private Sub CommandButton1_Click()
' Filterung Aufgabensammlung bzw. Aufgabensammlung aus
Dim sht_AS As Worksheet
Dim sht_Dec As Worksheet
Set sht_AS = Worksheets("Aufgabensammlung")
Set sht_Dec = Worksheets("Decisions")
If sht_AS.FilterMode Then sht_AS.ShowAllData
' Die Variable lngLetzteAufgabensammlung wird als Typ Long deklariert
Dim lngLetzteAufgabensammlung As Long
Dim lngLetzteAufgabensammlungNeu As Long
' Die Variable lngLetzteMinutes wird als Typ Long deklariert
Dim lngLetzteMinutes As Long
' Die Variable lngLetzteTERMINPLAN wird als Typ Long deklariert
Dim lngLetzteTERMINPLAN As Long
' Die Variable lngLetzteDecisions wird als Typ Long deklariert
Dim lngLetzteDecisions As Long
Dim a As Range, b As Range, c As Range
' Die Laufvariablen i, j, k, l, x, y und z werden als Typ Long deklariert
Dim i As Long, j As Long, k As Long, l As Long, w As Long, x As Long, y As Long, z As Long
Application.ScreenUpdating = False
' Letzte belegte Zelle in Spalte E plus 1 raussuchen und merken
lngLetzteMinutes = Range("C" & Rows.Count).End(xlUp).Row + 1
'MsgBox (lngLetzteMinutes)
' Letzte belegte Zelle in Spalte E plus 1 raussuchen und merken
lngLetzteAufgabensammlung = sht_AS.Range("B" & Rows.Count).End(xlUp).Row + 1
'MsgBox (lngLetzteAufgabensammlung)
lngLetzteDecisions = sht_Dec.Range("C" & Rows.Count).End(xlUp).Row + 1
'MsgBox (lngLetzteDecisions)
'Fuchs 12.03.2013: Auflösung Filteransicht in Reiter "Aufgabensammlung"
j = lngLetzteAufgabensammlung
For Each cl In Range("E2:E" & lngLetzteMinutes).SpecialCells(xlCellTypeConstants)
z = 0
i = cl.Row
x = 0
Do 'überschrift finden
x = x - 1
Thema = cl.Offset(x, -2)
Loop Until cl.Offset(x, -2).Font.Bold = True
If Cells(i, 5) = "A" Then
For k = 8 To lngLetzteAufgabensammlung Step 1 'Durchsuchen des Aufgabensammlung, ob _
Aufgabe bereits vorhanden'
If Cells(i, 3) = sht_AS.Cells(k, 4) Then
z = z + 1
End If
Next k
If z = 0 Then
sht_AS.Cells(lngLetzteAufgabensammlung, 2) = CDate(Cells(i, 2)) 'Datum'
sht_AS.Cells(lngLetzteAufgabensammlung, 3) = Thema 'Cells(i, 3) 'Aufgabe'
sht_AS.Cells(lngLetzteAufgabensammlung, 4) = Cells(i, 3) 'Stichwort'
'Fuchs 12.03.13: Text aufgabe aus Minutes übernehmen!
'sht_AS.Cells(lngLetzteAufgabensammlung - 1, 5).Copy sht_AS.Cells( _
lngLetzteAufgabensammlung, 5)'
sht_AS.Cells(lngLetzteAufgabensammlung, 5) = Cells(i, 5) 'Info/Aufgabe'
sht_AS.Cells(lngLetzteAufgabensammlung, 7) = Cells(i, 6) 'Verantwortlicher'
sht_AS.Cells(lngLetzteAufgabensammlung, 8) = CDate(Cells(i, 7)) 'Datum'
'sht_AS.Cells(lngLetzteAufgabensammlung, 9) = Cells(i, 8) 'Anlage'
sht_AS.Cells(lngLetzteAufgabensammlung, 9) = Cells(i, 9) 'Prio'
'sht_AS.Cells(lngLetzteAufgabensammlung - 1, 10).Copy sht_AS.Cells( _
lngLetzteAufgabensammlung, 10) 'Status'
With sht_AS.Cells(lngLetzteAufgabensammlung, 4)
If InStr(Cells(i, 3), "Hardware") > 0 Then .Value = "Hardware"
If InStr(Cells(i, 3), "Mechanik") > 0 Then .Value = "Mechanik"
If InStr(Cells(i, 3), "Software") > 0 Then .Value = "Software"
End With
' Hochsetzten Variablen
lngLetzteAufgabensammlung = lngLetzteAufgabensammlung + 1
'lngLetzteTERMINPLAN = lngLetzteTERMINPLAN + 1
y = y + 1
End If
ElseIf Cells(i, 5) = "D" Then
x = 0
For k = 8 To lngLetzteDecisions Step 1 'Durchsuchen des Decisions, ob Entscheidung _
bereits vorhanden'
If Cells(i, 3) = sht_Dec.Cells(k, 3) Then
x = x + 1
End If
Next k
If x = 0 Then
sht_Dec.Cells(lngLetzteDecisions, 2) = Cells(6, 3) 'Datum'
sht_Dec.Cells(lngLetzteDecisions, 3) = Cells(i, 3) 'Text Entscheidung'
sht_Dec.Cells(lngLetzteDecisions, 4) = Cells(i, 4) 'Stichwort'
sht_Dec.Cells(lngLetzteDecisions, 5) = Cells(i, 5) 'Entscheidung'
sht_Dec.Cells(lngLetzteDecisions, 6) = Cells(8, 3) 'Verantwortlicher'
sht_Dec.Cells(lngLetzteDecisions, 8) = Cells(i, 8) 'Anlage'
lngLetzteDecisions = lngLetzteDecisions + 1
'lngLetzteTERMINPLAN = lngLetzteTERMINPLAN + 1
w = w + 1
End If
End If
Next cl
'Nach Einfügen der Aufgabensammlung-Punkte Anzahl der Zeilen zählen
lngLetzteAufgabensammlungNeu = sht_AS.Cells(Rows.Count, 3).End(xlUp).Row
'Druckbereich anpassen Aufgabensammlung'
sht_AS.PageSetup.PrintArea = Range(Cells(1, 1), Cells(lngLetzteAufgabensammlungNeu, 11)). _
Address
'Druckbereich anpassen Decisions'
sht_Dec.PageSetup.PrintArea = Range(Cells(1, 1), Cells(lngLetzteDecisions - 1, 7)).Address
'Rahmen setzen
sht_AS.Range("B2:I" & lngLetzteAufgabensammlungNeu).Borders.LineStyle = xlContinuous
sht_Dec.Range("B2:H" & lngLetzteDecisions - 1).Borders.LineStyle = xlContinuous
' Bildschirmaktualisierung EINschalten (nicht vergessen) 'wird am Ende der Prozedur _
selbstständig eingeschaltet
Application.ScreenUpdating = True
' Meldung absetzten, dass Übertragung erfolgreich war.
If y = 0 And w = 0 Then
MsgBox "Alle Aufgaben und Entscheidungen bereits in der Aufgabensammlung vorhanden. _
Keine Übertragung erfolgt.", vbExclamation, "Keine Übertragung"
Else
MsgBox "Übertragung zu 100 % erfolgt." & vbCrLf & "Es wurden " & vbCrLf & y & " Aufgabe( _
n) in Aufgabensammlung und " & vbCrLf & w & " Entscheidung(en) in Decisions übertragen", vbInformation, "Alles gut!"
End If
End Sub