Unikatliste aus mehreren Sheets

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub M_snb() For Each it In Sheets it.Columns(1).AdvancedFilter 2, , Sheets(1).Cells(Rows.Count, 8).End(xlUp).Offset(1), True Next With Sheets(1).Columns(8) .SpecialCells(2).AdvancedFilter 2, , Sheets(1).Cells(1, 9), True .ClearContents End With End Sub

for i = 1 to 3 Sheets("T" & i).Range("A4:A44").Copy Sheets("Gesamt").Cells(Rows.Count, 1).End(xlup).Offset(1, 0).PasteSpecial xlpasteall next Sheets("Gesamt").Columns(1).RemoveDuplicates 1, xlno

Hallo Daniel,

gerade habe ich es geschafft und es funzt. Die "Function" habe ich beim Googlen gerade noch gefunden.

Sub ArrayFuellen()
   Dim arrWerte(), ArrZutaten() As String, lLastRow&
   Dim lTab&     '* Tabellenzähler
   Dim lZaehler& '* Zähler für Array-Datenzeilen
   Im lRow&      '* Zeilenzähler in den Törtchen-Sheets
   
   '* letzte Zeile in den Törtchen-Sheets
      lLastRow = Tab03.Cells(Rows.Count, "C").End(xlUp).Row - 7
   
   Application.ScreenUpdating = False
   
   '* alle Sheets durchlaufen
      For lTab = 3 To Worksheets.Count
         With Worksheets(lTab)
            For lRow = 4 To lLastRow
               If .Cells(lRow, 2) = "" Then GoTo next_tab
                  lZaehler = lZaehler + 1
                  ReDim Preserve arrWerte(lZaehler)
                  arrWerte(lZaehler) = .Cells(lRow, 2)
            Next lRow
            lRow = 1
         End With
next_tab:
      Next lTab
   
   '* vorhandene Zutatenliste löschen
      Range("A4:A" & lRow + 1).ClearContents
   
   '* Function starten
      ArrZutaten = ArrayDuplikateEntfernen(arrWerte)
   
   '* Zutaten-Array in Tabelle eintragen
      lRow = UBound(ArrZutaten)
      Range("A4:A" & lRow + 3) = Application.Transpose(ArrZutaten)
      Range("A4:A" & lRow + 3).Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlNo
End Sub


Function ArrayDuplikateEntfernen(MeinArray As Variant) As Variant
   Dim nErste&, nLetzte&, i&, Element$, arrTemp() As String, Coll As New Collection

   'Erste und letzte Array-Position ermitteln
   nErste = LBound(MeinArray)
   nLetzte = UBound(MeinArray)
   ReDim arrTemp(nErste To nLetzte)

   'Array in String umwandeln
   For i = nErste To nLetzte
       arrTemp(i) = CStr(MeinArray(i))
   Next i
   
   'Temporäre Sammlung auffüllen
   On Error Resume Next
   For i = nErste To nLetzte
       Coll.Add arrTemp(i), arrTemp(i)
   Next i
   Err.Clear
   On Error GoTo 0

   'Größe des Arrays ändern
   nLetzte = Coll.Count + nErste - 1
   ReDim arrTemp(nErste To nLetzte)
   
   'Array auffüllen
   For i = nErste To nLetzte
       arrTemp(i) = Coll(i - nErste + 1)
   Next i
   
   'Array ausgeben
   ArrayDuplikateEntfernen = arrTemp
End Function

Vielen Dank

Servus

Dim X Dim sh Dim dic Dim arr1dim Dim arr2dim Set dic = CreateObject("scripting.dictionary") For Each sh In Sheets(Array("T1", "T2", "T3")) For Each X In Range(sh.Cells(2, 1), sh.Cells(Rows.Count, 1).End(xlUp)).Value If X > "" Then dic(X) = 0 Next Next arr1dim = dic.keys 'Ergebnis in eindimensionalen Array (entspricht einer Zeile mit vielen Spalten) Basis 0 arr2dim = WorksheetFunction.Transpose(dic.keys) 'Ergebnis in zweidimensionalen Array in einer Spalte und vielen Zeilen Basis 1

Sub HG() Dim objZU As Object, arrZU, i As Long Dim wks As Worksheet Set objZU = CreateObject("scripting.dictionary") objZU("Zutaten") = 0 'die Überschrift For Each wks In Worksheets(Array("t1", "t2", "t3")) With wks arrZU = Intersect(.Cells(1, 1).CurrentRegion, .Cells(1, 1).CurrentRegion.Offset(1)) For i = 1 To UBound(arrZU) objZU(arrZU(i, 1)) = 0 Next i End With Next wks 'Zutaten in Array arrZU = Application.Transpose(objZU.keys) 'Zutaten in Blatt With Sheets("gesamt-unikatliste") .Columns(1).ClearContents .Cells(1, 1).Resize(UBound(arrZU)) = arrZU End With End Sub

Dim X Dim sh As Worksheet Dim txt As String Dim arr1dim Dim arr2dim For Each sh In Sheets(Array("T1", "T2", "T3")) For Each X In Range(sh.Cells(2, 1), sh.Cells(Rows.Count, 1).End(xlUp)).Value If X > "" Then _ If InStr(txt & "|", "|" & X & "|") = 0 Then txt = txt & "|" & X Next Next arr1dim = Split(Mid(txt, 2), "|") arr2dim = WorksheetFunction.Transpose(arr1dim)

Beliebteste Forumthreads (12 Monate)

28 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread