Mischen eines Tabellenblattes - Mehrdimensionale Felder

[kathrin-Flint]

Hallo liebe VBA Profis,

ich möchte gerne die Zellen auf meinem Tabellenblatt mischen. Dazu habe ich mir folgendes Makro
geschrieben:

Code:

Public Sub Mischen()

Dim i As Variant, fFeld() As Variant, iTemp As Variant, iZ As Variant
Dim Werte() As Variant
    
    C = ActiveCell.Row - 1
    
    anz = InputBox("Anzahl der zu mischenden Werte = ")
    
    ReDim fFeld(anz)
    For i = 1 To anz
        fFeld(i) = i
    Next i
      
    For i = anz To 1 Step -1
        Randomize Timer
        iZ = Int((i * Rnd) + 1)
        iTemp = fFeld(iZ)
        fFeld(iZ) = fFeld(i)
        fFeld(i) = iTemp
    Next i
    
    For a = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
    ReDim Werte(anz)
    For i = 1 To anz
    Werte(i) = Cells(i + C, a)
    Next i
    
    For i = 1 To anz
        'Cells(i, 2) = fFeld(i)
        Cells(fFeld(i) + C, a) = Werte(i)
    Next i
    Next a
    
End Sub

Das Problem bei dem jetzigen Makro ist dass durch das Durchlaufen der Schleife

For a = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
..
..
Next a

die Performance nicht so besonders ist. Bei grosser Zeilenanzahl habe ich schnell ein Sanduhrprogramm. Wie kann der Code verbessert werden, dass mit optimaler Geschwindigkeit gemischt wird? Meine Idee wäre
irgendwie ein mehrdimensionales Feld zu entwickeln, hab bisher aber keine Ahnung bezüglich dessen Umsetzung. Bin aber auch für alle anderen Ideen offen.

[schauan]

Hallo Kathrin,

ich bin mir nicht sicher, ob Du mit Deiner Frage darauf abzielst, die Einträge aller Zeilen und Spalten der Excel-Tabelle zu mischen oder nur innerhalb der jeweiligen Spalte oder ...

Ich habe hier mal in Deinem code ein paar Änderungen vorgenommen, mit denen man alle Zeilen und Spalten mischen würde. Siehe dazu die Kommentare im code.

Variablendeklarationen und anderes sind sicher auch noch verbesserungswürdig ... Hier aber erst mal der code. Unten müsste dann noch die Übertragung des Arrays in die Tabelle dran. Getestet hab ich das erst mal nur mit zwei Spalten.

Code:

Public Sub Mischen()

Dim i As Variant, a As Variant, fFeld() As Variant, iTemp As Variant, sTemp As Variant, tTemp As Variant, iZ As Variant
Dim Werte() As Variant
    
    C = ActiveCell.Row - 1
    
'    anz = InputBox("Anzahl der zu mischenden Werte = ")
    
    'benutzten Bereich in Array einlesen
    sTemp = ActiveSheet.UsedRange
    'Anzahl Eintraege ermitteln anhand "Spalten" und "Zeilen"
    anz = UBound(sTemp, 1) * UBound(sTemp, 2)
    'Zielarray dimensionieren
    ReDim tTemp(1 To UBound(sTemp, 1), 1 To UBound(sTemp, 2))
    
    ReDim fFeld(1 To anz)
    For i = 1 To anz
        fFeld(i) = i
    Next i
      
    For i = anz To 1 Step -1
        Randomize Timer
        iZ = Int((i * Rnd) + 1)
        iTemp = fFeld(iZ)
        fFeld(iZ) = fFeld(i)
        fFeld(i) = iTemp
    Next i
    
    'Schleife ueber alle Zufallszahlen
    For a = 1 To UBound(fFeld)
        'Uebernahme des fFeld(a) Eintrages in das a-te Feld des Zielarrays.
        'Zielposition finden:
        'Die Position der "Zeile" wird anhand des Restwertes der Division des fFeld(a) Eintrages durch die Anzahl der
        '"Spalten" ermittelt. Da bei der letzten "Zeile" der Restwert 0 ist, muss er durch die Zeilenzahl ersetzt werden.
        'Die "Spalte" ergibt sich durch Aufrunden  der Division des fFeld(a) Eintrages durch die Anzahl der
        '"Spalten"
        'Queleintrag finden:
        'Berechnung wie Zielposition, jedoch mit a statt fFeld(a)
        tTemp(Replace(fFeld(a) Mod UBound(sTemp, 1), 0, UBound(sTemp, 1)), WorksheetFunction.RoundUp((fFeld(a) / UBound(sTemp, 1)), 0)) = _
        sTemp(Replace(a Mod UBound(sTemp, 1), 0, UBound(sTemp, 1)), WorksheetFunction.RoundUp((a / UBound(sTemp, 1)), 0))
    Next a
    
    'ab hier Uebertragung auf das Tabellenblatt
    
End Sub

[kathrin-Flint]

Hallo André,
interessante Idee die du da vorstellst. Aber leider
läuft der Code noch nicht.

[schauan]

Hallo Kathrin,

schreib mal bitte, wo es klemmt bzw. stelle den kompletten code ein, falls Du was ergänzt oder geändert hast.

Für die Übertragung der gemischten Daten kannst Du z.B. so vorgehen. Ich habe es hier auf ein anderes Blatt ausgegeben.

Sheets("Tabelle2").Cells(1, 1).Resize(UBound(sTemp, 1), UBound(sTemp, 2)) = tTemp

[kathrin-Flint]

Hallo André,

der Compiler unterstreicht genau diese Zeilen gelb:
tTemp(Replace(fFeld(a) Mod UBound(sTemp, 1), 0, UBound(sTemp, 1)), WorksheetFunction.RoundUp((fFeld(a) / UBound(sTemp, 1)), 0)) = _
sTemp(Replace(a Mod UBound(sTemp, 1), 0, UBound(sTemp, 1)), WorksheetFunction.RoundUp((a / UBound(sTemp, 1)), 0))

(P.S. Verwende eine 64 Bit Office Version, weiß nicht ob das damit zusammenhängen könnte.)

[schauan]

Hallo Kathrin,

es könnte daran liegen, dass bei Replace ein Text erwartet oder erzeugt wird und das 32er Office da etwas toleranter ist.
Aber was wir letztens öfter hatten - eventuell geht vor dem WorksheetFunction noch Application. (mit dem Punkt)

[Kuwer]

Hallo Zusammen,

habe mich auch mal daran versucht ohne Replace, Mod und RoundUp:

Code:

Public Sub Mischen_Kuwer()
  Dim i As Long, iZ As Long, j As Long, k As Long, lngAnzahl As Long
  Dim fFeld() As Variant, iTemp As Variant, sTemp As Variant, tTemp As Variant
  Dim Werte() As Variant
    
  'Bereich in Array einlesen
  sTemp = Tabelle5.Range("A1:C6").Value
  'Anzahl Eintraege ermitteln anhand "Spalten" und "Zeilen"
  lngAnzahl = UBound(sTemp, 1) * UBound(sTemp, 2)
  'Zielarray dimensionieren
  ReDim tTemp(1 To UBound(sTemp, 1), 1 To UBound(sTemp, 2))
  
  ReDim fFeld(1 To lngAnzahl, 1 To 3)
  
  For j = 1 To UBound(sTemp, 2)
    For i = 1 To UBound(sTemp, 1)
      k = k + 1
      fFeld(k, 1) = k
      fFeld(k, 2) = i
      fFeld(k, 3) = j
    Next i
  Next j
    
  For i = lngAnzahl To 1 Step -1
    Randomize Timer
    iZ = Int((i * Rnd) + 1)
    iTemp = fFeld(iZ, 1)
    fFeld(iZ, 1) = fFeld(i, 1)
    fFeld(i, 1) = iTemp
  Next i
  
  k = 0
  For j = 1 To UBound(tTemp, 2)
    For i = 1 To UBound(tTemp, 1)
      k = k + 1
      tTemp(i, j) = sTemp(fFeld(fFeld(k, 1), 2), fFeld(fFeld(k, 1), 3))
    Next i
  Next j
  
  'ab hier Uebertragung auf das Tabellenblatt
  Tabelle4.Cells(20, 1).Resize(UBound(tTemp, 1), UBound(tTemp, 2)).Value = tTemp
End Sub

Gruß Uwe

[kathrin-Flint]

Hallo Uwe,

leider bekomme ich den von Dir geschriebenen Code nicht zum laufen.
D.h. es gibt keine Ergebnisausgabe in das Tabellenblatt 4. Es passiert leider gar nichts.

[Kuwer]

Hallo,

die Tabellen(namen) in meinem Code sind die Codenamen,
die im VBA-Editor an erster Stelle stehen und nicht die
Registernamen, die im VBA-Editor in Klammern stehen.

Gruß Uwe

[Kathrin Doppelbauer]

Hi Leute,

hier mein Lösungsvorschlag:
(Code-Verbesserungen ausdrücklich erwünscht! - Danke.)

Code:

Sub MischenZeilenweise()
Dim i As Long, z As Long, dblT As Variant, dum as Variant

'Anzahl der zu mischenden Zeilen:
zeilen = 65500
Dim varL As Variant
ReDim varL(zeilen)

For s = 1 To zeilen
varL(s) = Rows(s & ":" & s).Value
Next s

For i = zeilen To 1 Step -1
Randomize Timer
iZ = Int((i * Rnd) + 1)
dum = varL(iZ)
varL(iZ) = varL(i)
varL(i) = dum
Next i

'Übertragung der gemischten Zeilen in Tabellenblatt 2
For x = 1 To zeilen
Tabelle2.Rows(x & ":" & x).Value = varL(x)
Next x

End Sub