VBA Doppler und Mehrfache weg

Bild

Betrifft: VBA Doppler und Mehrfache weg
von: WalterK
Geschrieben am: 25.05.2015 12:49:45

Hallo,
im Netz habe ich den folgenden Code gefunden, damit aus einer Spalte jeder Eintrag nur noch 1mal vorkommt.
Jetzt habe ich eine Tabelle mit ca. 50 Spalten und mit unterschiedlichen Längen. Wie muss der Code geändert werden, damit auf einen Rutsch die 50 Spalten bearbeitet werden? Die Überschriften sind immer in der Zeile 2!

Private Sub Worksheet_Activate()
 
    Dim i As Long
    Dim oDict As Object
 
    Set oDict = CreateObject("scripting.dictionary")
    Const intZ = 3
 
    With Worksheets("Tabelle1")
        For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
        If Len(Trim(.Cells(i, 1))) Then oDict(.Cells(i, 1).Text) = ""
        Next i
    End With
 
    Worksheets("Tabelle2").Cells(intZ, 1).Resize(oDict.Count, 1) = Application.Transpose(oDict. _
keys)
 
 
End Sub
Besten Dank für die Hilfe, Servus Walter

Bild

Betrifft: AW: VBA Doppler und Mehrfache weg
von: Sepp
Geschrieben am: 25.05.2015 13:11:38
Hallo Walter,

' **********************************************************************
' Modul: Modul4 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub cleanLists()
  Dim lngCol As Long, lngEndCol As Long, lngLast As Long
  Dim vntIn As Variant, vntOut As Variant
  
  With ActiveSheet
    lngEndCol = Application.Max(1, .Cells(1, .Columns.Count).End(xlToLeft).Column)
    For lngCol = 1 To lngEndCol
      lngLast = Application.Max(2, .Cells(.Rows.Count, lngCol).End(xlUp).Row)
      vntIn = .Range(.Cells(2, lngCol), .Cells(lngLast, lngCol))
      vntOut = toArrayUnique(vntIn, 0)
      If IsArray(vntOut) Then
        .Range(.Cells(2, lngCol), .Cells(lngLast, lngCol)).Clear
        .Cells(2, lngCol).Resize(UBound(vntOut) + 1, 1) = Application.Transpose(vntOut)
      End If
    Next
  End With
  
End Sub


Function toArrayUnique(Field As Variant, Optional Sort As Integer = 1) As Variant
  'Sort unsortiert = 0, sortiert A-Z = 1, sortiert Z-A = -1
  Dim objArrayList As Object
  Dim lngR As Long, lngC As Long
  
  On Error GoTo ErrExit
  
  Set objArrayList = CreateObject("System.Collections.Arraylist")
  
  With objArrayList
    For lngR = LBound(Field, 1) To UBound(Field, 1)
      For lngC = LBound(Field, 2) To UBound(Field, 2)
        If Not .Contains(Trim(Field(lngR, lngC))) Then
          If Field(lngR, lngC) <> "" Then .Add Trim(Field(lngR, lngC))
        End If
      Next
    Next
    If Sort <> 0 Then .Sort
    If Sort < 0 Then .Reverse
    toArrayUnique = .toArray
  End With
  
  Exit Function
  ErrExit:
  toArrayUnique = -1
End Function


Gruß Sepp

Bild

Betrifft: AW: VBA Doppler und Mehrfache weg
von: WalterK
Geschrieben am: 25.05.2015 13:24:53
Hallo Sepp,
perfekt, wie man es von Dir gewohnt ist.
Freut mich, wieder von Dir zu lesen.
Servus, Walter

Bild

Betrifft: AW: VBA Doppler und Mehrfache weg
von: Sepp
Geschrieben am: 25.05.2015 13:28:54
Servus Walter,
freut mich, dass es klappt.
>>Freut mich, wieder von Dir zu lesen.<< Na Ja. Ich muss meine eingerosteten "Excel-Finger" wieder etwas auf die Probe stellen ;-))

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Alle Zeilen mit Eintrag markieren (ab Zeile 10)"