Zellinhalte mischen, Tabellenübergreifend

Computer: Software & Programmierung Office Software
1

na, da bin ich leider schon wieder.

Euer Macro (Reinhards + Niclaus Modifikation) funktioniert wie erwünscht. ( 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

2

Alternativ: Verbundene Zellen ebenso unangetastet
Falls obriges nicht möglich sein sollte ginge es auch wenn ich sämtliche Tabellen zusammenfüge (mach ich dann manuell).
Dann aber sollten die verbundenen Zellen (als Überschriftersatz) ebenso unangetastet bleiben wie die leeren Zellen - ist dies denn möglich?

3

Falls obriges nicht möglich sein sollte ginge es auch wenn ich
sämtliche Tabellen zusammenfüge (mach ich dann manuell).
Dann aber sollten die verbundenen Zellen (als
Überschriftersatz) ebenso unangetastet bleiben wie die leeren
Zellen - ist dies denn möglich?

Hallo EP,

manuell ist nicht nötig, das kann Vba auch.
Teste halt mal den Code gründlich an einer Kopie der Originalmappe.

Option Explicit

Sub Misch()
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "xyz"
Call Mischfunktion(1) ' 1 = 1te Spalte=A
Call Mischfunktion(5) ' 5 = 5te Spalte=E
Application.DisplayAlerts = False
Worksheets("xyz").Delete
Application.DisplayAlerts = True
Worksheets(1).Activate
End Sub

Sub Mischfunktion(Spa As Integer)
Dim Zei(100) As Long, Z As Long, Zahl As Long, wks As Worksheet
Dim Von As Long
Application.ScreenUpdating = False
With Worksheets("xyz")
 For Each wks In Worksheets
 If wks.Name "xyz" Then
 Z = Z + 1
 Zei(Z) = wks.Cells(wks.Rows.Count, Spa).End(xlUp).Row
 wks.Range(wks.Cells(2, Spa), wks.Cells(Zei(Z), Spa)).Copy Destination:=.Cells(Zei(0) + 1, Spa)
 Zei(0) = Zei(0) + Zei(Z) - 1
 Zei(Z) = Zei(0)
 End If
 Next wks
 .Columns(Spa).Insert
 With .Range(.Cells(1, Spa), .Cells(Zei(0), Spa))
 .FormulaLocal = "=Wenn(" & Chr(65 + Spa) & "1="""";Zeile();"""")"
 .Copy
 .PasteSpecial Paste:=xlValues
 End With
 Application.CutCopyMode = False
 For Z = 1 To Zei(0)
 If .Cells(Z, Spa) = "" Then
 Do
 Zahl = Int(Rnd() \* Zei(0)) + 1
 Loop While Application.CountIf(.Columns(Spa), Zahl) \> 0
 .Cells(Z, Spa).Value = Zahl
 End If
 Next Z
 .Range(.Cells(1, Spa), .Cells(Zei(0), Spa + 1)).Sort Key1:=.Cells(1, Spa), Order1:=xlAscending, Header:=xlNo, \_
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 .Columns(Spa).Delete
 Z = 0
 For Each wks In Worksheets
 If wks.Name "xyz" Then
 Z = Z + 1
 Von = IIf(Z = 1, 1, Zei(Z - 1) + 1)
 .Range(.Cells(Von, Spa), .Cells(Zei(Z), Spa)).Copy Destination:=wks.Cells(2, Spa)
 End If
 Next wks
End With
Application.ScreenUpdating = True
End Sub

Gruß
Reinhard

4

Auf Reinhard kann man sich halt verlassen :smile:
Vielen Vielen Dank!!