Guten morgen,
ich habe ein super Skript/Macro von Reinhard bekommen. ( 0
Cells(Z, Spa).Value = Zahl
End If
Next Z
Range(Cells(1, Spa), Cells(Zei, Spa + 1)).Sort Key1:=Cells(1, Spa), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(Spa).Delete
Range(„A1“).Select
Application.ScreenUpdating = True
End Sub
Das einzige was ich nun noch bräuchte, wäre, dass die ganze
Funktion erst ab A2 bzw. E2 anfängt - um nicht die
Tabellenüberschrift mitzumischen.Cells(Z, Spa).Value = Zahl
End If
Next Z
Hier (also ziemlich am Ende des Makros) würde ich einfügen
Cells(1, Spa) = 0
Range(Cells(1, Spa), Cells(Zei, Spa + 1)).Sort Key1:=Cells(1,
Spa), Order1:=xlAscending, Header:=xlNo, _
Grüsse Niclaus
Hallo EP,
Das einzige was ich nun noch bräuchte, wäre, dass die ganze
Funktion erst ab A2 bzw. E2 anfängt - um nicht die
Tabellenüberschrift mitzumischen.Ich wäre euch sehr dankbar, da ich die Listen (vermischt)
heute abliefern sollte.
tut mir Leid, ich lese das eben erst.
Tut mir Leid2, ich sah schon daß du das mit der zweiten Zeile schon im anderen Thread sagtest, aber ich dachte du kriegst das alleine hin.
Ich habe jetzt ungetestet im Code nur die 1 gegen gegen 2 getauscht.
Wenn es nicht klappen sollte melde dich dann teste ich es und passe den Code entsprechend an.
Nachstehend der geänderte Code.
Und wenn du hier Code postest so benutze bitte den pre-Html-Tag, der wird unterhalb des Eingabefensters, wenn du was schreibst, erläutert.
Damit bleiben Einrückungen im Code durch Leerzeichen erhalten.
Gruß
Reinhard
Option Explicit
'
Sub Misch()
Call Mischfunktion(1) ' 1 = 1te Spalte=A
Call Mischfunktion(5) ' 5 = 5te Spalte=E
Range("A1").Select
End Sub
'
Sub Mischfunktion(Spa As Integer)
Dim Zei As Long, Z As Long, Zahl
Zei = Cells(Rows.Count, Spa).End(xlUp).Row
Application.ScreenUpdating = False
Columns(Spa).Insert
With Range(Cells(2, Spa), Cells(Zei, Spa))
.FormulaLocal = "=Wenn(" & Chr(65 + Spa) & "2="""";Zeile();"""")"
.Copy
.PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
For Z = 2 To Zei
If Cells(Z, Spa) = "" Then
Do
Zahl = Int(Rnd() \* Zei) + 1
Loop While Application.CountIf(Columns(Spa), Zahl) \> 0
Cells(Z, Spa).Value = Zahl
End If
Next Z
Range(Cells(2, Spa), Cells(Zei, Spa + 1)).Sort Key1:=Cells(2, Spa), Order1:=xlAscending, Header:=xlNo, \_
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(Spa).Delete
Application.ScreenUpdating = True
End Sub
mit dem Code vermischt er die Leerzeichen wieder mit 
mit dem Code vermischt er die Leerzeichen wieder mit
hallo EP,
du meinst die Leer Zellen der Spalten?
Okay, ich teste es demnächst.
Gruß
Reinhard
sorry, Leerzellen mischt er nun mit, ja
auch damit vermischt er leider die Leerzellen wieder mit
auch damit vermischt er leider die Leerzellen wieder mit
Entschuldige bitte. Da hab ich schlecht kontrolliert.
Hier die Version, die ich nun x-mal geprüft habe, und die immer zum richtigen Ergebnis geführt hat.
Option Explicit
Sub Misch()
Call Mischfunktion(1) ' 1 = 1te Spalte=A
Call Mischfunktion(5) ' 5 = 5te Spalte=E
End Sub
Sub Mischfunktion(Spa As Integer)
Dim Zei As Long, Z As Long, Zahl
Zei = Cells(Rows.Count, Spa).End(xlUp).Row
Application.ScreenUpdating = False
Columns(Spa).Insert
With Range(Cells(1, Spa), Cells(Zei, Spa))
.FormulaLocal = "=Wenn(" & Chr(65 + Spa) & "1="""";Zeile();"""")"
.Copy
.PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
Cells(1, Spa) = 1
For Z = 1 To Zei
If Cells(Z, Spa) = "" Then
Do
Zahl = Int(Rnd() \* Zei) + 1
Loop While Application.CountIf(Columns(Spa), Zahl) \> 0
Cells(Z, Spa).Value = Zahl
End If
Next Z
Range(Cells(1, Spa), Cells(Zei, Spa + 1)).Sort Key1:=Cells(1, Spa), Order1:=xlAscending, Header:=xlNo, \_
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(Spa).Delete
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Die Zeile „Cells(1,Spa)=1“ hatte ich blöderweise nach, statt vor der Schleife eingesetzt.
Gibst Du mir (und vor allem Reinhard) Bescheid, ob es jetzt klappt?
Grüsse Niclaus
super! - nun funktioniert alles so wie es soll.
Ihr seid echt top,
Danke,
EP
Sehr schön, danke Niclaus 
o.w.T.