Makro effizienter machen

Guten Tag,

ich hab folgendes Problem, da ich mich in VBA nicht gut auskenne: Bei dem unten abgebildeten Makro ist das Ziel Das Blatt "Arbeit" mit den restlichen Blättern zu vergleichen, nach möglichen Duplikaten schauen und wenn ein Duplikat auftaucht dieses zu löschen. Problem hierbei ist, dass es eine ewig lange Durchlaufzeit hat, da das Blatt Arbeit jedes Mal neu durchlaufen wird.
Ist es möglich die anderen Blätter z.B. in Array zu packen und das Blatt "Arbeit" dann nur noch mit dem Array, in dem sich alle anderen Blätter zu vergleichen, um so Zeit einzusparen?

Vielen Dank schon mal im Voraus und ich bin gespannt auf eure Ideen!

LG Julian

Dim k As Long

With Sheets("Arbeit")

    For k = .Cells(Rows.Count, "CV").End(xlUp).Row To 2 Step -1

        If Application.IsNumber(Application.Match(.Cells(k, "CV"), Sheets("Arbeit 1").Columns(100), 0)) Then

            .Cells(k, "CV").EntireRow.Delete

        ElseIf Application.IsNumber(Application.Match(.Cells(k, "CV"), Sheets("Arbeit 2").Columns(100), 0)) Then

            .Cells(k, "CV").EntireRow.Delete

        ElseIf Application.IsNumber(Application.Match(.Cells(k, "CV"), Sheets("Arbeit 3").Columns(100), 0)) Then

            .Cells(k, "CV").EntireRow.Delete

        ElseIf Application.IsNumber(Application.Match(.Cells(k, "CV"), Sheets("Arbeit 4").Columns(100), 0)) Then

            .Cells(k, "CV").EntireRow.Delete

        ElseIf Application.IsNumber(Application.Match(.Cells(k, "CV"), Sheets("Arbeit 5").Columns(100), 0)) Then

            .Cells(k, "CV").EntireRow.Delete

        ElseIf Application.IsNumber(Application.Match(.Cells(k, "CV"), Sheets("Arbeit 6").Columns(100), 0)) Then

            .Cells(k, "CV").EntireRow.Delete

        ElseIf Application.IsNumber(Application.Match(.Cells(k, "CV"), Sheets("Arbeit 7").Columns(100), 0)) Then

            .Cells(k, "CV").EntireRow.Delete

        ElseIf Application.IsNumber(Application.Match(.Cells(k, "CV"), Sheets("Arbeit 8").Columns(100), 0)) Then

            .Cells(k, "CV").EntireRow.Delete

        End If

    Next

End With



End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Duplikate_Löschen_mehrere_Arbeitsblätter() Dim wsh As Worksheet Dim sp As Long sp = 100 With Sheets("neu") .cells.Clear .Cells(1, 1).Value = 0 For Each wsh In ThisWorkbook.Worksheets If wsh.Name Like "Arbeit *" Then wsh.UsedRange.Columns(sp).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues End If Next .Columns(1).RemoveDuplicates 1, xlNo .Columns(1).Sort Key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo End With With Sheets("Arbeit").UsedRange With .Columns(.Columns.Count + 1) .FormulaR1C1 = "=IF(VLookUp(RC" & sp & ",neu!C1,1,1)=RC" & sp & ",0,Row())" .Cells(1, 1).Value = 0 .EntireRow.RemoveDuplicates .Column, xlNo .ClearContents End With End With Sheets("neu").Cells.Clear End Sub

Sub Duplikate_Löschen_mehrere_Arbeitsblätter() Dim wsh As Worksheet Dim Dic Dim Z Set Dic = CreateObject("Scripting.Dictionary") 'Inhalt der Spalten 100 sammeln For Each wsh In ThisWorkbook.Worksheets If wsh.Name > "Arbeit" Then For Each Z In wsh.UsedRange.Columns(100) Dic(Z.Value) = 1 Next End If Next 'prüfen und löschen Application.ScreenUpdating = False Application.EnableEvents = False With Worksheets("Arbeit").UsedRange.Columns(100) For Each Z In .Cells If Dic.Exists(Z.Value) Then Z.Value = True Next .SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete End With Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Sub Makro1() With Sheets("Arbeit") lz1 = .Cells(Rows.Count, "CV").End(xlUp).Row For k = 2 To lz1 Wert = .Cells(k, "CV").Value If Application.WorksheetFunction.CountIf(Sheets("Arbeit1").Columns(100), Wert) > 0 Then GoTo Clr If Application.WorksheetFunction.CountIf(Sheets("Arbeit2").Columns(100), Wert) > 0 Then GoTo Clr If Application.WorksheetFunction.CountIf(Sheets("Arbeit3").Columns(100), Wert) > 0 Then GoTo Clr If Application.WorksheetFunction.CountIf(Sheets("Arbeit4").Columns(100), Wert) > 0 Then GoTo Clr If Application.WorksheetFunction.CountIf(Sheets("Arbeit5").Columns(100), Wert) > 0 Then GoTo Clr If Application.WorksheetFunction.CountIf(Sheets("Arbeit6").Columns(100), Wert) > 0 Then GoTo Clr If Application.WorksheetFunction.CountIf(Sheets("Arbeit7").Columns(100), Wert) > 0 Then GoTo Clr If Application.WorksheetFunction.CountIf(Sheets("Arbeit8").Columns(100), Wert) = 0 Then GoTo Nxt Clr: .Cells(k, "CV").Value = Empty ' oder "###" in Spalte CV einfügen Nxt: 'weiter ohne löschen Next k For k = lz1 To 2 Step -1 If .Cells(k, "CV").Value = Empty Then .Rows(k).Delete shift:=xlUp End If Next k End With End Sub

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread