Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 12:56:25
Werte von Kunden und Artikel stehen untereinander
25.04.2024 12:55:42
Funktionsparameter auslesen
25.04.2024 11:49:37
Array verwenden
25.04.2024 10:38:52
Bedingte Formatierung per VBA / MaxPoint
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1424to1428
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1424to1428
1424to1428
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

VBA Doppler und Mehrfache weg

VBA Doppler und Mehrfache weg
25.05.2015 12:49:45
WalterK
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Doppler und Mehrfache weg
25.05.2015 13:11:38
Sepp
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

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

AW: VBA Doppler und Mehrfache weg
25.05.2015 13:28:54
Sepp
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 ;-))

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige