Wie oft ? vba

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub vorkommen() Dim ende As Long Dim zeile As Long Dim eintrag As Long Dim werte() ReDim werte(0) Worksheets(2).Columns(1).ClearContents ende = Worksheets(1).Cells(Rows.Count, 3).End(xlUp).Row eintrag = 3 For zeile = 1 To ende If UBound(Filter(werte, "xyz" & Worksheets(1).Cells(zeile, 3) _ & "zyx", , vbTextCompare)) = -1 And Worksheets(1).Cells(zeile, 3) "" Then Worksheets(2).Cells(eintrag, 1) = Worksheets(1).Cells(zeile, 3) eintrag = eintrag + 1 ReDim Preserve werte(UBound(werte) + 1) werte(UBound(werte)) = "xyz" & Worksheets(1).Cells(zeile, 3) & "zyx" End If Next zeile End Sub

Hallo,
Da gibt eineig Möglichkeiten.
Pivotabelle geht, Spezialfilter ohne Duplikate geht, Formellösung geht...
Die brauchen aber bei vielen Unikaten möchtig viel Zeit.
Richtig schnell ist sowas:

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub machs()
    Dim L As Long
    Dim myDic As Object
    Dim Arr As Variant
    Dim Element As Variant
    Set myDic = CreateObject("Scripting.Dictionary")
    With Sheets("Tabelle1")
        Arr = .Range("A1:A100000").Value 'Anpassen
        'unikate sammeln
        For L = LBound(Arr) To UBound(Arr)
            myDic(Arr(L, 1)) = 0
        Next
        'Ausgabearray dimnsionieren
        Redim out(1 To myDic.Count, 1 To 1)
        L = 1
        'Umschaufeln
        For Each Element In myDic.keys
            out(L, 1) = Element
            L = L + 1
        Next
        'ausgeben
        .Range("B1").Resize(myDic.Count, 1) = out 'Anpassen
    End With
End Sub

ransi

Hallo Hans,
ein bisschen wenig Infos, aber versuche mal folgendes. Code in ein allgemeines Modul, eine Schaltfläche auf den Blatt und der Schaltfläche das Makro zuweisen.

Option Explicit
Public Sub Hans()
Dim loLetzte As Long
Dim loLetzte1 As Long
loLetzte = Sheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Row
loLetzte1 = Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("Tabelle1")
Sheets("Tabelle2").Range(Sheets("Tabelle2").Cells(3, 1), Sheets("Tabelle2").Cells(loLetzte1, 1)) _
.ClearContents
.Range(.Cells(2, 3), .Cells(loLetzte, 3)).Copy Sheets("Tabelle2").Range("A3")
End With
With Sheets("Tabelle2").Range("A:A")
.RemoveDuplicates Columns:=1, Header:=xlYes
End With
End Sub

Ich bin mal davon ausgegangen, dass die Daten im Blatt1 ab Zelle A2 beginnen (A1 Überschrift). Bei Ausführen des Makros werden die Daten in Blatt 2 A3-A? gelöscht, dann aus Blatt 1 in Blatt 2 kopiert und dann die Doppler entfernt.
Gruß Werner

Option Explicit Public Sub Hans() Dim loLetzte As Long Dim loLetzte1 As Long loLetzte = Sheets("Tabelle1").Cells(Rows.Count, 7).End(xlUp).Row loLetzte1 = Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row With Sheets("Tabelle1") Sheets("Tabelle2").Range(Sheets("Tabelle2").Cells(3, 1), Sheets("Tabelle2").Cells(loLetzte1, 1)) _ .ClearContents .Range(.Cells(4, 7), .Cells(loLetzte, 7)).Copy Sheets("Tabelle2").Range("A3") End With With Sheets("Tabelle2").Range("A:A") .RemoveDuplicates Columns:=1, Header:=xlYes End With End Sub

Beliebteste Forumthreads (12 Monate)

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread