Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 08:08:24
Pivot Vormonatsveränderung
26.04.2024 07:54:11
nur den ersten Eintrag in spalte zählen
25.04.2024 23:47:55
Datum ausweisen, wenn definierte Summe erreicht ist
25.04.2024 21:40:53
Excel Datenquelle aus dem Web mit Anmeldung?
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1920to1924
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1920to1924
1920to1924
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Archivierung von Zeilen

Archivierung von Zeilen
24.02.2023 14:06:32
Zeilen
Hallo zusammen!
Wenn die Zeile auf erledigt gesetzt wurde, dann soll die Zeile in das andere Tabellenblatt "Archiv" verschoben werden. Am Code wurde nichts geändert, die datei ansich kopiert und die möglichen Bezüge zur alten Datei entfernt. Wo könnte das Problem sein?

On Error Resume Next
If Not Intersect(Target, Rows(10).Find("STATUS").EntireColumn) Is Nothing Then 'WENN aktuelle Zelle (Target) keine Übereinstimmung mit der Auswahl (Spalte W) hat -> STOP
If Target.Count > 1 Then Exit Sub 'WENN mehr als eine Zelle ausgewählt -> STOP
If Target = "erledigt" Then 'WENN Auswahl "erledigt" ist, DANN weiter

If Target.Offset(0, 11) = "X" Then 'WENN 11 Spalten rechts neben der aktuellen Zelle (also in Spalte AH) ein "X" steht
'd.h. es handelt sich um Hauptzeile des Projekts, DANN
projID = Worksheets("Projektplan").Cells(Target.Row, 3).Value 'Projekt ID des Projekts aus Spalte C lesen
j = 11 'Suche Zeile für Zeile nach Kopien des Projekts bzw. beteiligten Fachbereichen anhand der Projekt ID
Do
j = j + 1
If Cells(j, 3).Value = projID And Target.Row > j Then 'WENN Projekt ID in Zeile j und Spalte C gefunden UND Zeile j nicht die Zeile der aktuellen Zelle ist
'DANN ist das Projekt noch bei einem beteiligten Fachbereich aufgeführt -> Message Box
'HINWEIS: Es müssen erst alle beteiligten Fachbereiche auf "erledigt" gesetzt sein, bevor Hauptzeile "erledigt" werden kann
MsgBox "Eine Kopie dieses Projekts ist in Zeile " & j & " enthalten. Setzen Sie die Hauptzeile (Zeile: " & Target.Row & ") erst zu 'erledigt', wenn alle Kopien 'erledigt' sind, da sonst die Zellbezüge verloren gehen."
Exit Do

ElseIf Cells(j, 3).Value = "" And Cells(j + 1, 3).Value = "" Then 'ANSONSTEN WENN nächste und übernächste Zelle (j + 1 und j + 2) leer sind, so ist man am Ende
'der Projektliste angelangt und es gibt offenbar keine beteiligten Fachbereiche zu diesem Projekt (außer der Hauptverantwortliche)
'MsgBox "Hauptzeile ohne Kopien!"
Call Archive(Target) 'DANN archiviere das Projekt mit der Sub-Function "Archive" (siehe unten)
Exit Do
End If
Loop

Else 'WENN es sich nicht um die Hauptzeile des Projekts handelt
'MsgBox "Keine Hauptzeile!"
Call Archive(Target) 'DANN archiviere das Projekt mit der Sub-Function "Archive" (siehe unten)

End If

End If

Sub Archive(Target As Range)
'MsgBox "Checkpoint: Archive"
i = 11
Do
i = i + 1

If Target.Offset(0, -21) = Worksheets("Archiv").Cells(i, 2).Value And Worksheets("Archiv").Cells(i + 1, 2).Value > Target.Offset(0, -21) Then
Worksheets("Archiv").Rows(i + 1).Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromRightOrBelow
Exit Do

ElseIf Worksheets("Archiv").Cells(i + 1, 2).Value = "" And Worksheets("Archiv").Cells(i + 2, 2).Value = "" Then
Worksheets("Archiv").Rows(i + 1).Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromRightOrBelow
MsgBox " Keine übereinstimmende Gruppe gefunden !"
Exit Do

End If

Loop

Target.Rows(1).EntireRow.Copy
Worksheets("Archiv").Rows(i + 1).PasteSpecial Paste:=xlValues ', Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Beim Verschieben ins Archiv gehen Bezüge verloren -> daher "Paste:=xlValues" um nur Werte zu kopieren
Target.Rows(1).EntireRow.Delete Shift:=xlUp
MsgBox " Projekt wird im Archiv in Zeile " & i + 1 & " eingefügt."
End Sub

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Archivierung von Zeilen
24.02.2023 18:49:17
Zeilen
Hallo Lilli,
If Not Intersect(Target, Rows(10).Find("STATUS").EntireColumn) Is Nothing Then
Ich gehe davon aus, dass die Überschriftszeile weiterhin in Zeile 10 zu finden ist...
If Target.Offset(0, 11) = "X" Then
ziemlich schräg: zuerst auf einem veränderbare Status-Spalte, dann jetzt aber sehr festem Bezug. Was wenn eine Spalte innerhalb der 11 Spalten nach "Status" hinzugefügt wurde?
Ist der "X" immer gross? Sicherheitshalber: If UCase(Target.Offset(0, 11)) = "X" Then
Dein Code ist ohne die originale Datei nicht zu debuggen.
Schalte den "On Error" aus, setze einen oder mehreren Breakpoint und gehe durch in Schrittmodus.
Verwende die Lokalfenster ("Ansicht", "Lokalfenster") und setze Überwachungsausdrücke ein.
Mehr kann man aus der Ferne nicht machen.
VG
Yal
Anzeige
AW: Archivierung von Zeilen
24.02.2023 20:09:20
Zeilen
Hallo Lilli,
es braucht ein Bischen Zeit, bis man den Code durchschaut, aber viel ist nicht drin.
Es wird geprüft, ob der ProjID eindeutig ist,
dann gesucht, wo die letzte Zeile bezüglich einem nicht näher benannten Identifier liegt,
und direkt danach (eine Zeile nach unten) als Wert eingefügt.
Um den Code "leichter" zu erfassen, habe ich Eindeutigkeit in einer Sub und Suche+Insert in einer zweiten abgelegt. Sieht so aus:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A, B
On Error Resume Next
    If Target.Count > 1 Then Exit Sub 'WENN mehr als eine Zelle geändert wurde, dann nicht handeln
    A = Target.Column = Rows(10).Find("STATUS").Column 'fand in Spalte Status statt
    B = Target.Column = Rows(10).Find("-da wo der X reinkommt-").Column 'fand in Spalte ... statt: ANPASSEN
    If A Or B Then
        If A And LCase(Target.Value) = "erledigt" Or B And UCase(Target.Value) = "X" Then
            If Eindeutigkeit_prüfen(Target) Then Zeile_archivieren Target
        End If
    End If
End Sub
Private Function Eindeutigkeit_prüfen(ByVal Target As Range) As Boolean
Dim Z As Range
Dim StartAdresse As String
'Prüfung der Eindeutigkeit der ID. Starte ab Zeile 12
    With Worksheets("Projektplan").Range(Range("C12"), Cells(Rows.Count, "C").End(xlUp))
        Set Z = .Find(Cells(Target.Row, "C").Value) 'Projekt ID des Projekts aus Spalte C lesen
        If Not Z Is Nothing Then
            StartAdresse = Z.Address
            Do
                If Z.Row > Target.Row Then Exit Function 'Abbruch im Stand Eindeutigkeit_prüfen = False
                Set Z = .FindNext(Z)
            Loop While Z.Address > StartAdresse
        End If
    End With
    Eindeutigkeit_prüfen = True 'es wurde keine andere ProjID in Spalte C gefunden
End Function
Sub Zeile_archivieren(ByVal Target As Range)
Dim Z As Range
'Passiert alles im Blatt "Archiv"
    With Worksheets("Archiv")
    'finde letzte Zeile mit ...
        Set Z = .Columns(2).Find(Target.Offset(0, -21).Value, SearchDirection:=xlPrevious)
    'falls nichts gefunden, letzte befüllte Zelle in Spalte B nehmen
        If Z Is Nothing Then Set Z = .Cells(Rows.Count, 2).End(xlUp)
        Z.Offset(1).EntireRow.Insert Shift:=xlDown 'Neue Zeile danach einfügen
        Set Z = Z.Offset(1) 'wechseln zu neuer Zeile
        Target.EntireRow.Copy
        Z.PasteSpecial xlValues 'Formel werden eingefroren, weil sonst "#BEZUG!"
        Target.EntireRow.Delete Shift:=xlUp
    End With
    MsgBox "Projekt wurde im Archiv in Zeile " & Z.Row & " abgelegt."
End Sub
Achte auf meinen vorigen Hinweise.
Passt den Namen der zweite Spalte an
Überlege eine bessere Version für "Target.Offset(0, -21).Value"
Wie immer: ohne Beispieldatei heisst ungetestet.
VG
Yal
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige