Re: Sortieren in mehreren Blätter, im Hintergrund mögl
16.06.2003 14:48:54
L.Vira
Sorry, aber das ist dann doch too much, das nachzuvollziehen.
Daher nur etwas Kosmetik:Option Explicit
Sub DeinMakro()
Dim aa, bb, cc, dd, thequarter, st
Dim wert2, wert3, wert4, x, xx, ts, zu
aa = 0
bb = 3
dd = 0
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
For thequarter = 1 To 42
cc = 1
aa = aa + 1
Sheets("Besetzung").Select
Cells(aa, 3).Select
st = ActiveCell.Value
If st = 0 Then Cells(aa, 1).Select
If st = 1 Then Cells(aa, 2).Select
If st = 1 Then ActiveCell.FormulaR1C1 = "nicht besetzt"
If st = 1 Then GoTo ENDE
wert2 = ActiveCell.Value
Mitarbeiter:
cc = cc + 1
If cc = 52 Then GoTo ENDE
Sheets("Mitarbeiter").Select
Cells(cc, 3).Select
wert3 = ActiveCell.Value
If wert2 = wert3 Then Cells(cc, 2).Select
If wert2 <> wert3 Then GoTo Mitarbeiter
wert4 = ActiveCell.Value
Sheets("Besetzung").Select
Cells(aa, 2).Select
ActiveCell.FormulaR1C1 = wert4
Sheets("Mitarbeiter").Select
Cells(cc, 1).Select
ActiveCell.Value = False
ENDE:
Next thequarter
xx = 0
x = 4
For x = 4 To 12
NACHSORTIEREN:
xx = xx + 1
If xx = 43 Then GoTo ENDE1
Sheets("Besetzung").Select
Cells(xx, 2).Select
ts = ActiveCell.Value
If ts = 0 Then GoTo ZELLE
If ts <> 0 Then GoTo NACHSORTIEREN
ZELLE:
Cells(xx, 1).Select
wert2 = ActiveCell.Value
cc = 1
ERSATZ:
cc = cc + 1
If cc = 52 Then GoTo NACHSORTIEREN
Sheets("Mitarbeiter").Select
Cells(cc, x).Select
wert3 = ActiveCell.Value
If wert2 = wert3 Then Cells(cc, 2).Select
If wert2 <> wert3 Then GoTo ERSATZ
wert4 = ActiveCell.Value
Sheets("Besetzung").Select
Cells(xx, 2).Select
ActiveCell.FormulaR1C1 = wert4
Sheets("Mitarbeiter").Select
Cells(cc, 1).Select
ActiveCell.Value = False
ENDE1:
If xx < 43 Then GoTo NACHSORTIEREN
xx = 0
Next x
cc = 1
xx = 1
SONSTIGE:
cc = cc + 1
If cc = 52 Then GoTo ENDESONSTIGE
Sheets("Mitarbeiter").Select
Cells(cc, 1).Select
If ActiveCell.Value = False Then GoTo SONSTIGE
If ActiveCell.Value = True Then Cells(cc, 2).Select
zu = ActiveCell.Value
xx = xx + 1
Sheets("Besetzung").Select
Cells(xx, 6).Select
ActiveCell.FormulaR1C1 = zu
GoTo SONSTIGE
ENDESONSTIGE:
Sheets("Drucken").Select
Range("a1").Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub