Tabelle teilweise kopieren

Ich habe eine Tabelle mit 8000 Datensätzen (soll variabel sein)
Spalte A sind Namen (string)
Spalte B ist das Geburtsland (string)
Nun möchte ich die Tabelle kopieren (Spalte A nach F und Spalte B nach G)
Hierbei sollen dann alle Zeilen ignoriert werden, die bei Geburtsland einen bestimmten Wert haben (z.B. Brasilien)
Wenn Brasilien z.B. 500x vorkommt, hat die neue Tabelle nur noch 7500 Einträge.
Die Herausforderung:
Da es Werte in den Spalten A und B gibt, können die Spalten nicht einfach nach F und G kopiert werden und die Zeilen danach gelöscht werden, da dann ja auch die Quelle (Spalte A und B) verändert wird.
Die neue Tabelle soll unbedingt neben der Quelle stehen, daher Spalte F und G.
Ein Makrocode der jede einzelne Zeile nach einem kompletten Kopiervorgang der Tabelle kontrolliert, ggf. die Zellen (nicht Zeilen) löscht und dann die restlichen Zeilen um eine Zeile nach oben verschiebt (um die Lücke zu schließen), erscheint mir von der Laufzeit zu hoch. Das würde dann Stunden dauern.
Eine Kontrolle vor dem Kopieren jeder einzelnen Zeile wird bestimmt genauso lange dauern.
Mir fehlt die zündende Idee.
Hat Jemand einen brauchbaren Ansatz?
Ich freue mich schon :-)
Gruß Siggi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Unit() Dim A, B Dim x As Long, y As Long Dim Exclusion As String Exclusion = "Brasilien" A = Cells(1, 1).CurrentRegion.Columns("A:B").Value ReDim B(1 To UBound(A, 1), 1 To 2) For x = 1 To UBound(A, 1) If A(x, 2) Exclusion Then y = y + 1 B(y, 1) = A(x, 1) B(y, 2) = A(x, 2) End If Next Range("F1").Resize(UBound(B, 1), 2) = B End Sub

Sub Unit2() Dim A, B Dim x As Long, y As Long Dim Exclusion1 As String Dim Exclusion2 As String Dim Exclusion3 As String Exclusion1 = "Brasilien" Exclusion2 = "Italien" Exclusion3 = "Schweden" A = Cells(1, 1).CurrentRegion.Columns("A:B").Value ReDim B(1 To UBound(A, 1), 1 To 2) For x = 1 To UBound(A, 1) If A(x, 2) Exclusion1 And A(x, 2) Exclusion2 And A(x, 2) Exclusion3 Then y = y + 1 B(y, 1) = A(x, 1) B(y, 2) = A(x, 2) End If Next Range("F1").Resize(UBound(B, 1), 2) = B End Sub

Public Sub aaa() Dim loLetzte As Long Application.ScreenUpdating = False With Worksheets("Tabelle1") loLetzte = .Cells(.Rows.Count, "B").End(xlUp).Row .Columns("F:H").ClearContents .Columns("A:B").Copy .Columns("F") .Range(.Cells(2, "H"), .Cells(loLetzte, "H")).FormulaLocal = _ "=WENN(ODER(G2=""Brasilien"";G2=""Italien"";G2=""Schweden"");0;Zeile())" .Range(.Cells(2, "H"), .Cells(loLetzte, "H")).Value = .Range(.Cells(2, "H"), _ .Cells(loLetzte, "H")).Value .Range("H2") = 0 .Range("$F$2:$H$" & loLetzte).RemoveDuplicates Columns:=3, Header:=xlNo .Columns("H").ClearContents End With End Sub

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread