Live-Forum - Die aktuellen Beiträge
Datum
Titel
17.05.2024 13:03:50
Minuten mehrerer Zeiteinträge für ein Zeitintervall summier
17.05.2024 12:55:57
Tolles Forum, tolle Informationen, danke ... doch leider
17.05.2024 12:45:34
Abwesenheiten Auswertung
17.05.2024 12:39:58
Wenn Zelleninhalt dann Inhalt aus verschiedenen auswählen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1956to1960
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
1956to1960
1956to1960
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt

Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt
20.12.2023 00:29:26
Valor
Hallo Zusammen
folgende VBA-Problemstellung. Ich möchte in einer Array (C4:J50), bei Spalten mit gleichen Inhalte in den ersten 3 Spalten, die kompletten dazugehörigen Zeilen ausschneiden und auf ein neues Blatt hinzufügen.
Die verschobenen Zeilen sollen im neuen selbst benannten Blatt 'Doppelt' untereinander unter dem gleichen Tabellentitel eingereiht sein.

Bitte um Lösungsansätze

https://www.herber.de/bbs/user/165402.xlsm

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

Betreff
Datum
Anwender
Anzeige
AW: Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt
20.12.2023 08:27:17
MCO
Moin!

Das Makro macht genau was du wolltest:
Sub doppelte_Auslagern()



    Dim Ureintrag_übertragen  As Boolean

    Dim new_sh  As Worksheet

    Set new_sh = ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count))

    new_sh.Name = "Doppelt"

    Sheets(1).Select

    Set dat_rng = Sheets(1).Range("C4:C99").SpecialCells(xlCellTypeConstants)

    

    Rows(4).Copy new_sh.Cells(1, "A") 'Überschriften

    

    For Each cl In dat_rng

    

        If WorksheetFunction.CountIf(Range("C:C"), cl) > 1 Then

            'Mehrfach

            For Each such_satz In Range(cl.Offset(1, 0), Range("C100"))

                If cl.Value = such_satz _

                    And cl.Offset(0, 1).Value = such_satz.Offset(0, 1) _

                    And cl.Offset(0, 2).Value = such_satz.Offset(0, 2) Then '3 Bedingungen

                    'Übertrag

                    

                    With new_sh

                        If Ureintrag_übertragen = False Then

                            lz = .Cells(Rows.Count, "B").End(xlUp).Row + 1

                            Rows(cl.Row).Copy .Cells(lz, "A") 'nur 1x

                            Ureintrag_übertragen = True

                        End If

                        lz = .Cells(Rows.Count, "B").End(xlUp).Row + 1

                        Rows(such_satz.Row).Copy .Cells(lz, "A")

                        such_satz.ClearContents

                    End With

                End If

            Next such_satz

            cl.ClearContents

            Ureintrag_übertragen = False

        End If

    Next cl

    

    Set dat_rng = dat_rng.SpecialCells(xlCellTypeBlanks) 'geleerte Zellen im Bereich

    dat_rng.Rows.EntireRow.Delete 'komplette Zeilen löschen

End Sub


Gruß, MCO
Anzeige
AW: Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt
20.12.2023 19:04:43
Valor
Dankesehr! Hat funktioniert

Links zu Excel-Dialogen

Frame

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige