Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt

Forumthread: 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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

AW: Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt

20.12.2023 19:04:43

Valor

Dankesehr! Hat funktioniert

Beliebteste Forumthreads (12 Monate)

Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt

Forumthread: Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt

Forumthread: Spalte durchsuchen n. Doppelwert,auschneiden ins neues blatt

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread