Registriert seit: 13.04.2014
Version(en): 365, 2019
Hallo Ralf,
ich habe mal was eingebaut in den Code für ein neues Projekt:
Code: Sub neuesProjekt()
'
' neuesProjekt anlegen
'
Dim loLetzte As Long
Dim loA As Long
Dim loB As Long
Dim loErl As Long
Dim loLae As Long
Dim loAbg As Long
Dim loWart As Long
Dim loAnz As Long
Dim rng As Range
'
' loZeile = ActiveCell.Row
Application.EnableEvents = False
loLetzte = Sheets("Protokoll").Cells(Rows.Count, 4).End(xlUp).Row ' letzte belegte in Spalte D (4)
For loA = 1 To loLetzte
If (Cells(loA, 7) = "P") And (Cells(loA, 4) = "") Then
If Not Range("G1:G" & loLetzte).Find("P", Cells(loA, 7)) Is Nothing Then
loB = Range("G1:G" & loLetzte).Find("P", Cells(loA, 7)).Row
If loB < loA Then loB = loLetzte + 1
End If
Debug.Print loA, loB
loAnz = loB - loA
Set rng = Range(Cells(loA + 1, 7), Cells(loB - 1, 7))
loLae = Application.WorksheetFunction.CountIf(rng, "läuft")
loErl = Application.WorksheetFunction.CountIf(rng, "erledigt")
loAbg = Application.WorksheetFunction.CountIf(rng, "abgebrochen")
loWart = Application.WorksheetFunction.CountIf(rng, "wartet")
If loLae > 0 Then 'mindestens ein "läuft" => läuft
Cells(loA, 4) = "läuft"
ElseIf loErl = loAnz Then 'alle "erledigt" >= erledigt
Cells(loA, 4) = "erledigt"
ElseIf loAbg = loAnz Then 'alle abgebrochen >= abgebrochen
Cells(loA, 4) = "abgebrochen"
ElseIf loWart = loAnz Then 'alle "wartet" >= wartet
Cells(loA, 4) = "wartet"
ElseIf loErl > loAbg Then
Cells(loA, 4) = "erledigt" 'Mehrheit "erledigt", Minderheit "abgebrochen" => erledigt
ElseIf loWart < loAnz / 2 Then 'Minderheit "wartet" >= läuft
Cells(loA, 4) = "läuft"
End If
End If
Next
'nach Edgar ------------------------
Rows(loLetzte + 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A" & loLetzte & ":G" & loLetzte).Copy Range("A" & loLetzte + 1 & ":G" & loLetzte + 1)
If Range("G" & loLetzte) = "A" Then
Range("G" & loLetzte + 1) = "P" 'neues Projekt in letzter Zeile
Range("B" & loLetzte + 1).ClearContents 'löschen der alten Projektnummer für neues Projekt
' Range("C" & loLetzte + 2) = Range("C" & loLetzte) 'Umgehen des "grünes Dreieck"-Fehlers
End If
Range("D" & loLetzte + 1).Clear
Range("B" & loLetzte + 1).Select
Application.EnableEvents = True
End Sub
Gruß
Edgar
Meine Antworten sind freiwillig und ohne Gewähr!
Über Rückmeldungen würde ich mich freuen.
Folgende(r) 1 Nutzer sagt Danke an BoskoBiati für diesen Beitrag:1 Nutzer sagt Danke an BoskoBiati für diesen Beitrag 28
• Rabe
Registriert seit: 10.04.2014
Version(en): 2016 + 365
Hi Edgar,
(19.10.2016, 14:03)BoskoBiati schrieb: ich habe mal was eingebaut in den Code für ein neues Projekt:
danke.
Wenn ich es richtig verstehe, wird überprüft, ob die Spalte D in der Zeile mit "P" leer ist und dann wird etwas eingetragen.
Wenn aber ein Mal was in der Zelle drin steht, wird es dann nicht mehr erneut aktualisiert.
Es wird überall "läuft" eingetragen, egal was in den Zellen drunter steht.
Ich habe das Makro jetzt aus der Sub "neuesProjekt" rausgenommen und als eigenes Makro auf einen Button gelegt.
Protokoll erweitern - V3.xlsb (Größe: 47,38 KB / Downloads: 1)
Registriert seit: 10.04.2014
Version(en): 2016 + 365
25.10.2016, 10:16
(Dieser Beitrag wurde zuletzt bearbeitet: 25.10.2016, 10:17 von Rabe.)
Hallo,
hier nochmal als Wiedervorlage:
Ich habe bei der Datei und dem Makro "Status aktualisieren" noch zwei Probleme
- wenn in Spalte D in der Zeile mit "P" etwas eingetragen ist, daß dann dieser Inhalt nicht mehr erneut aktualisiert wird.
- Es wird überall "läuft" eingetragen, egal was in den Zellen drunter steht.
Hier die Vorgaben für die Spalte D in der "P"-Zeile:
- alle "läuft" => "läuft"
- alle "erledigt" => "erledigt"
- alle "abgebrochen" => "abgebrochen"
- alle "wartet" => "wartet"
- Mehrheit "erledigt", "abgebrochen" oder "wartet", Minderheit "läuft" => läuft
- Mehrheit "erledigt", "abgebrochen", Minderheit "wartet" => läuft
- Mehrheit "erledigt", Minderheit "abgebrochen" => "erledigt"
- fehlt noch was?
Dann ist etwas neues aufgetaucht:
Wenn in Spalte D gefiltert wird, kommt bei Einfügen einer Zeile eine Fehlermeldung (jetzt gerade beim Nachtesten kam der Fehler plötzlich nicht mehr), in folgender Code-Zeile:
Code: Range("A" & loZeile & ":G" & loZeile).Copy Range("A" & loZeile + 1 & ":G" & loZeile + 1)
Hier die Makros:
Option Explicit
Sub ZeileEinfügen()
'
' 18.10.2016 - RaB
'
Dim loZeile As Long
'
Application.ScreenUpdating = False
loZeile = ActiveCell.Row
'nach Edgar ------------------------
Rows(loZeile + 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A" & loZeile & ":G" & loZeile).Copy Range("A" & loZeile + 1 & ":G" & loZeile + 1)
Range("G" & loZeile + 1) = "A"
Range("D" & loZeile + 1).ClearContents
'Range("C" & loZeile + 2) = Range("C" & loZeile) 'Umgehen des "grünes Dreieck"-Fehlers
'-----------------------------------
Range("H" & loZeile + 1).Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub fünfZeilenEinfügen()
'
' 18.10.2016 - RaB
'
Dim loZeile As Long
'
loZeile = ActiveCell.Row
Rows(loZeile + 1).Resize(5).EntireRow.Insert
Range("A" & loZeile & ":G" & loZeile).Copy Range("A" & loZeile + 1 & ":G" & loZeile + 5)
Range("G" & loZeile + 1 & ":G" & loZeile + 5) = "A"
Range("D" & loZeile + 1 & ":D" & loZeile + 5).ClearContents
Range("H" & loZeile + 1).Select
End Sub
Sub neuesProjekt()
'
' neuesProjekt anlegen
'
Dim loLetzte As Long
'
'loZeile = ActiveCell.Row
loLetzte = Sheets("Protokoll").Cells(Rows.Count, 4).End(xlUp).Row ' letzte belegte in Spalte D (4)
'nach Edgar ------------------------
Rows(loLetzte + 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A" & loLetzte & ":G" & loLetzte).Copy Range("A" & loLetzte + 1 & ":G" & loLetzte + 1)
If Range("G" & loLetzte) = "A" Then
Range("G" & loLetzte + 1) = "P" 'neues Projekt in letzter Zeile
Range("B" & loLetzte + 1).ClearContents 'löschen der alten Projektnummer für neues Projekt
'Range("C" & loLetzte + 2) = Range("C" & loLetzte) 'Umgehen des "grünes Dreieck"-Fehlers
End If
Range("D" & loLetzte + 1).ClearContents 'löschen des Status für neues Projekt
Range("B" & loLetzte + 1).Select
End Sub
Sub Status_aktualisieren()
'
' Status pro Projekt aktualisieren
'
Dim loLetzte As Long
Dim loA As Long
Dim loB As Long
Dim loErledigt As Long
Dim loLaeuft As Long
Dim loAbgebrochen As Long
Dim loWartet As Long
Dim loAnzahl As Long
Dim rng As Range
'
Application.EnableEvents = False
Application.ScreenUpdating = False
loLetzte = Sheets("Protokoll").Cells(Rows.Count, 4).End(xlUp).Row ' letzte belegte in Spalte D (4)
For loA = 1 To loLetzte
If (Cells(loA, 7) = "P") Then
Cells(loA, 4) = "" 'leeren der Projekt-Statuszelle
End If
If (Cells(loA, 7) = "P") And (Cells(loA, 4) = "") Then
If Not Range("G1:G" & loLetzte).Find("P", Cells(loA, 7)) Is Nothing Then
loB = Range("G1:G" & loLetzte).Find("P", Cells(loA, 7)).Row
If loB < loA Then loB = loLetzte + 1
End If
Debug.Print loA, loB
loAnzahl = loB - loA
Set rng = Range(Cells(loA + 1, 7), Cells(loB - 1, 7))
loLaeuft = Application.WorksheetFunction.CountIf(rng, "läuft")
loErledigt = Application.WorksheetFunction.CountIf(rng, "erledigt")
loAbgebrochen = Application.WorksheetFunction.CountIf(rng, "abgebrochen")
loWartet = Application.WorksheetFunction.CountIf(rng, "wartet")
If loLaeuft = loAnzahl Then 'alle "läuft" => "läuft"
Cells(loA, 4) = "läuft"
ElseIf loErledigt = loAnzahl Then 'alle "erledigt" => "erledigt"
Cells(loA, 4) = "erledigt"
ElseIf loAbgebrochen = loAnzahl Then 'alle "abgebrochen" => "abgebrochen"
Cells(loA, 4) = "abgebrochen"
ElseIf loWartet = loAnzahl Then 'alle "wartet" => "wartet"
Cells(loA, 4) = "wartet"
ElseIf loErledigt > loAbgebrochen Then 'Mehrheit "erledigt", Minderheit "abgebrochen" => "erledigt"
Cells(loA, 4) = "erledigt"
ElseIf loErledigt > loLaeuft Then 'Mehrheit "erledigt", Minderheit "läuft" => "läuft"
Cells(loA, 4) = "läuft"
ElseIf loAbgebrochen > loLaeuft Then 'Mehrheit "abgebrochen", Minderheit "läuft" => "läuft"
Cells(loA, 4) = "läuft"
ElseIf loWartet < loAnzahl / 2 Then 'Minderheit "wartet" => "läuft"
Cells(loA, 4) = "läuft"
ElseIf loLaeuft > 0 Then 'Mindestens 1x "läuft" => "läuft"
Cells(loA, 4) = "läuft"
End If
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Protokoll erweitern - V3.1.xlsb (Größe: 47,47 KB / Downloads: 1)
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
Hallo Ralf,
Du hast in Deinem Code ein Leeren des Eintrages in D:
Code: If (Cells(loA, 7) = "P") Then
Cells(loA, 4) = "" 'leeren der Projekt-Statuszelle
End If
Wenn das generell nicht erwünscht ist, dann müssen die 3 Zeilen weg.
Dann ist eine Bereichszuweisung wohl auch falsch.
Code: Set rng = Range(Cells(loA + 1, 7), Cells(loB - 1, 7))
Du verweist hier auf Spalte G (=7). Später prüfst Du in diesem Bereich, ob da z.B. läuft steht.
Code: loLaeuft = Application.WorksheetFunction.CountIf(rng, "läuft")
Steht dort nie, Du müsstest D prüfen
Die Zelleinträge für den Projektstatus setzt Du, wenn die Anzahl eines Status mit der Anzahl der Zellen eines Bereichs übereinstimmt, z.B..
Wenn Dein Bereich z.B. 3 Zellen enthält und eine davon der Projektstatus ist, wo ja noch nichts drin steht, müsstest Du die Anzahl um eins reduzieren. Also z.B. weiter oben
Code: loAnzahl = loB - loA - 1
. \\\|/// Hoffe, geholfen zu haben.
( ô ô ) Grüße, André aus G in T
ooO-(_)-Ooo (Excel 97-2019+365)
Registriert seit: 10.04.2014
Version(en): 2016 + 365
31.01.2017, 10:14
(Dieser Beitrag wurde zuletzt bearbeitet: 31.01.2017, 10:27 von Rabe.)
Hallo André,
danke für die Verbesserung!
Button Status aktualisieren:
Nun funktioniert es bis auf einen Teil des Punktes 5 aus meinem Beitrag von oben, dort wird im Falle Mehrheit "erledigt", Minderheit "läuft" oder "wartet" der Status auf "erledigt" gesetzt und nicht auf "läuft". Siehe Block VE0147.
Bitte in diesem Block mal alle drei Sachen durchprobieren: 1x "läuft", 1x "wartet", 1x "abgebrochen" bei jeweils 3x "erledigt"
irgendwie stimmt die Reihenfolge (und die Bedingungen) des zweiten ELSEIF-Blocks nicht.
Hier mal der Code:
Sub Status_aktualisieren()
'
' Status pro Projekt aktualisieren
'
Dim loLetzte As Long
Dim loA As Long
Dim loB As Long
Dim loErledigt As Long
Dim loLaeuft As Long
Dim loAbgebrochen As Long
Dim loWartet As Long
Dim loAnzahl As Long
Dim rng As Range
'
Application.EnableEvents = False
Application.ScreenUpdating = False
loLetzte = Sheets("Protokoll").Cells(Rows.Count, 4).End(xlUp).Row ' letzte belegte in Spalte D (4)
For loA = 1 To loLetzte
'################ evtl. entfernen
If (Cells(loA, 7) = "P") Then
Cells(loA, 4) = "" 'leeren der Projekt-Statuszelle
End If
'################
If (Cells(loA, 7) = "P") And (Cells(loA, 4) = "") Then
If Not Range("G1:G" & loLetzte).Find("P", Cells(loA, 7)) Is Nothing Then
loB = Range("G1:G" & loLetzte).Find("P", Cells(loA, 7)).Row
If loB < loA Then loB = loLetzte + 1
End If
Debug.Print loA, loB
loAnzahl = loB - loA - 1
Set rng = Range(Cells(loA + 1, 4), Cells(loB - 1, 4))
loLaeuft = Application.WorksheetFunction.CountIf(rng, "läuft")
loErledigt = Application.WorksheetFunction.CountIf(rng, "erledigt")
loAbgebrochen = Application.WorksheetFunction.CountIf(rng, "abgebrochen")
loWartet = Application.WorksheetFunction.CountIf(rng, "wartet")
If loLaeuft = loAnzahl Then 'alle "läuft" => "läuft"
Cells(loA, 4) = "läuft"
ElseIf loErledigt = loAnzahl Then 'alle "erledigt" => "erledigt"
Cells(loA, 4) = "erledigt"
ElseIf loAbgebrochen = loAnzahl Then 'alle "abgebrochen" => "abgebrochen"
Cells(loA, 4) = "abgebrochen"
ElseIf loWartet = loAnzahl Then 'alle "wartet" => "wartet"
Cells(loA, 4) = "wartet"
ElseIf loErledigt > loAbgebrochen Then 'Mehrheit "erledigt", Minderheit "abgebrochen" => "erledigt"
Cells(loA, 4) = "erledigt"
ElseIf loErledigt > loLaeuft Then 'Mehrheit "erledigt", Minderheit "läuft" => "läuft"
Cells(loA, 4) = "läuft"
ElseIf loAbgebrochen > loLaeuft Then 'Mehrheit "abgebrochen", Minderheit "läuft" => "läuft"
Cells(loA, 4) = "läuft"
ElseIf loWartet < loAnzahl / 2 Then 'Minderheit "wartet" => "läuft"
Cells(loA, 4) = "läuft"
ElseIf loLaeuft > 0 Then 'Mindestens 1x "läuft" => "läuft"
Cells(loA, 4) = "läuft"
End If
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
und hier die Datei:
Protokoll erweitern - V3.2.xlsb (Größe: 57,79 KB / Downloads: 0)
Registriert seit: 10.04.2014
Version(en): 2016 + 365
31.01.2017, 11:06
(Dieser Beitrag wurde zuletzt bearbeitet: 31.01.2017, 11:06 von Rabe.)
Hi,
ich habe es!
(31.01.2017, 10:14)Rabe schrieb: Button Status aktualisieren:
Nun funktioniert es bis auf einen Teil des Punktes 5 aus meinem Beitrag von oben, dort wird im Falle Mehrheit "erledigt", Minderheit "läuft" oder "wartet" der Status auf "erledigt" gesetzt und nicht auf "läuft". Siehe Block VE0147.
Bitte in diesem Block mal alle drei Sachen durchprobieren: 1x "läuft", 1x "wartet", 1x "abgebrochen" bei jeweils 3x "erledigt"
hier der 2. ELSEIF-Teil, falls es jemand mal durchspielen möchte:
ElseIf loLaeuft > 0 Then 'Mindestens 1x "läuft" => "läuft"
Cells(loA, 4) = "läuft"
ElseIf loWartet > 0 Then 'Mindestens 1x "wartet" => "läuft"
Cells(loA, 4) = "läuft"
' ElseIf loWartet < loAnzahl / 2 Then 'Minderheit "wartet" => "läuft"
' Cells(loA, 4) = "läuft"
ElseIf loErledigt > loAbgebrochen Then 'Mehrheit "erledigt", Minderheit "abgebrochen" => "erledigt"
Cells(loA, 4) = "erledigt"
' ElseIf loErledigt > loLaeuft Then 'Mehrheit "erledigt", Minderheit "läuft" => "läuft"
' Cells(loA, 4) = "läuft"
' ElseIf loAbgebrochen > loLaeuft Then 'Mehrheit "abgebrochen", Minderheit "läuft" => "läuft"
' Cells(loA, 4) = "läuft"
End If
|