alle mögl. Zellenkombinationen mit Makro auflisten

Sub Kreuztabelle_umsetzen() 'SheetNamen evt. anpassen sn1 = "Tabelle1" sn2 = "Tabelle2" nzeile = 1 'letze Zeilen ermitteln lZeileA = Sheets(sn1).Cells(65536, 1).End(xlUp).Row lZeileB = Sheets(sn1).Cells(65536, 2).End(xlUp).Row lZeileC = Sheets(sn1).Cells(65536, 3).End(xlUp).Row lZeileD = Sheets(sn1).Cells(65536, 4).End(xlUp).Row lZeileE = Sheets(sn1).Cells(65536, 5).End(xlUp).Row ' spalteninhalte löschen Sheets(sn2).Columns(1).ClearContents 'NullSpalte abfangen If lZeileA

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
danke für die schnellen Antworten.
@ Dirk: Bei der Suche nach Permutationen habe ich leider nichts gefunden, was mir behilflich sein könnte.
@ Luc: Danke für den Hinweis, dann handelt es sich um Variationen mit Wiederholung. Und es sind maximal 10 Begriffe in einer der Spalten, in einer anderen immer nur einer und in der dritten sind es ungefähr 4-6.
@ Steffen: Danke für den Link, ich hab das gleich mal mit Testdaten ausprobiert, nur leider ist das auch nicht die Lösung für meine Aufgabe. Ein Problem von diesem Makro ist u.A., dass wenn in einer Spalte weniger Werte sind als in den Anderen, diese nicht bei jeder Kombination berücksichtigt werden.
Nochmal ein kleines Beispiel, vielleicht kann ichs besser mit Worten beschreiben:
Ich habe gegeben:
Spalte 1: Katze
Spalte 2: rot
Spalte 3: hell
Das Ergebnis soll dann so aussehen:
hell Katze rot
hell rot Katze
Katze hell rot
Katze rot hell
rot hell Katze
rot Katze hell
Also dass jeder Begriff einmal den Platz getauscht hat mit den anderen.
Vielen Dank & Beste Grüße,
Marie

Option Explicit Const strDelim As String = "|" Sub SpaltenKombinieren() Application.ScreenUpdating = False Dim objKombi As Object, rngC As Range, lngCount As Long Dim arrKombi(), arrTmp, i As Long, j As Long Dim colKombi As New Collection Set objKombi = CreateObject("Scripting.Dictionary") For Each rngC In Range("A:C").Columns colKombi.Add _ Range(Cells(1, rngC.Column), Cells(Rows.Count, rngC.Column).End(xlUp)).Value Next Kombinieren_a colKombi, , objKombi If objKombi.Count > Rows.Count - 1 Then MsgBox "Zu viele Kombinationen (" & objKombi.Count & ")", , "Fehler" Else ReDim arrKombi(1 To objKombi.Count, 1 To colKombi.Count) For i = 1 To objKombi.Count arrTmp = Split(objKombi(i), strDelim) For j = 1 To colKombi.Count arrKombi(i, j) = arrTmp(j - 1) Next j Next i Workbooks.Add (1) Sheets(1).Cells(1, 1).Resize(UBound(arrKombi), UBound(arrKombi, 2)) = arrKombi End If Set objKombi = Nothing For lngCount = 1 To colKombi.Count colKombi.Remove 1 Next Application.ScreenUpdating = True End Sub Sub Kombinieren_a(colKombi, Optional strAusgabe As String, Optional objKombi) Dim i As Long, arrValues, j As Integer Static lngStep As Long lngStep = lngStep + 1 For i = 1 To UBound(colKombi(lngStep)) If lngStep 0 Then ReDim arrTmp(UBound(arrValues) - 1) For i = 0 To UBound(arrValues) If strErg = "" Then strTmp = arrValues(i) Else strTmp = strErg & strDelim & arrValues(i) End If k = 0 For j = 0 To UBound(arrValues) - 1 If i = j Then k = 1 arrTmp(j) = arrValues(j + k) Next j Kombinieren_b arrTmp, strTmp, objErg Next i Else objErg(objErg.Count + 1) = strErg & strDelim & arrValues(0) End If End Sub

Hallo,
1. Der Code gehört in ein Modul.
2. Einen Einzeiler hatte ich nicht vorgesehen. Ist korrigiert.
Es muss in jeder Spalte 1 Begriff stehen.

Const strDelim As String = "|"
Sub SpaltenKombinieren()
Application.ScreenUpdating = False
Dim objKombi As Object, rngC As Range, lngCount As Long
Dim arrKombi(), arrTmp, i As Long, j As Long
Dim colKombi As New Collection
Set objKombi = CreateObject("Scripting.Dictionary")
For Each rngC In Range("A:C").Columns
colKombi.Add _
Range(Cells(1, rngC.Column), Cells(Rows.Count, rngC.Column).End(xlUp)).Value
Next
Kombinieren_a colKombi, , objKombi
If objKombi.Count > Rows.Count - 1 Then
MsgBox "Zu viele Kombinationen (" & objKombi.Count & ")", , "Fehler"
Else
ReDim arrKombi(1 To objKombi.Count, 1 To colKombi.Count)
For i = 1 To objKombi.Count
arrTmp = Split(objKombi(i), strDelim)
For j = 1 To colKombi.Count
arrKombi(i, j) = arrTmp(j - 1)
Next j
Next i
Workbooks.Add (1)
Sheets(1).Cells(1, 1).Resize(UBound(arrKombi), UBound(arrKombi, 2)) = arrKombi
End If
Set objKombi = Nothing
For lngCount = 1 To colKombi.Count
colKombi.Remove 1
Next
Application.ScreenUpdating = True
End Sub
Sub Kombinieren_a(colKombi, Optional strAusgabe As String, Optional objKombi)
Dim i As Long, arrValues, j As Integer
Static lngStep As Long
lngStep = lngStep + 1
If IsArray(colKombi(lngStep)) Then
For i = 1 To UBound(colKombi(lngStep))
If lngStep  0 Then
ReDim arrTmp(UBound(arrValues) - 1)
For i = 0 To UBound(arrValues)
If strErg = "" Then
strTmp = arrValues(i)
Else
strTmp = strErg & strDelim & arrValues(i)
End If
k = 0
For j = 0 To UBound(arrValues) - 1
If i = j Then k = 1
arrTmp(j) = arrValues(j + k)
Next j
Kombinieren_b arrTmp, strTmp, objErg
Next i
Else
objErg(objErg.Count + 1) = strErg & strDelim & arrValues(0)
End If
End Sub

Gruß
Rudi

Beliebteste Forumthreads (12 Monate)

alle mögl. Zellenkombinationen mit Makro auflisten

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

313 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

alle mögl. Zellenkombinationen mit Makro auflisten

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

313 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread