AW: Code optimieren, verbessern
21.04.2011 04:15:25
fcs
Hallo Lorenz,
leider sind deine If-Bedingungen etwas unübersichtlich. Ich hab es umstrukturiert und statt "If" zum Teil "Select Case" verwendet, da hier übersichtlicher.
AUßerdem kann man die Wochentage in einer Schleife abarbeiten, so dass nicht für jeden Wochentag ein Codeabschnitt erstellt werden muss.
Gruß
Franz
Sub EintragAushang()
Dim iR As Integer, iC As Integer, iRz As Integer, iCz As Integer, iSt As Integer
Dim iWT As Long, bolEintragen As Boolean
Dim shAushang As Worksheet, iBeg As Integer, iEnd As Integer
Set shAushang = Sheets("Aushang")
With shAushang
With .Range("a3:u52")
.ClearContents
.Interior.ColorIndex = xlNone
End With
.Cells(1, 9).Value = ActiveCell
.Cells(1, 16).Value = .Cells(1, 9).Value + 6
End With
iBeg = 14
iEnd = 97
'für Wochentage
For iWT = 0 To 6 '0 = Montag, 6 = Sonntag
iRz = 3 'Startzeile im Aushang
iCz = 2 + iWT * 3 'Namensspalte im Aushang
iC = 1 'Namensspalte im Kalender
iSt = ActiveCell.Column + 1 + iWT * 2 'rechte Tages-Spalte im Kalender
For iR = iBeg To iEnd
bolEintragen = False
'Prüfen, ob Name in Aushang eingetragen werden soll - Wert in Spalte ABL (740)
If Cells(iR, 740) = "ja" Then
'Auswerten des Eintrags in der linken Spalte des Tages
Select Case Cells(iR, iSt - 1) 'linke Spalte prüfen
Case "K", "U", "F", "G"
'Prüfen ob Eintrag in rechter Spalte
If Cells(iR, iSt) "" Then bolEintragen = True
Case ""
'Prüfen ob Eintrag in rechter Spalte
If Cells(iR, iSt) "" Then bolEintragen = True
Case Else
bolEintragen = True
End Select
If bolEintragen = True Then
With shAushang
.Cells(iRz, iCz) = Cells(iR, iC) 'Name
If Cells(iR, iSt - 1) "" Then
.Cells(iRz, iCz - 1) = Cells(iR, iSt - 1) 'Eintrag in linker Spalte
End If
End With
'Auswerten Eintrag in rechter Spalte des Tages
Select Case Cells(iR, iSt)
Case "o", "u"
shAushang.Cells(iRz, iCz + 1) = "V6"
Case "O", "s"
shAushang.Cells(iRz, iCz + 1) = "V8"
Case ""
'do nothing
Case Else
shAushang.Cells(iRz, iCz + 1) = Cells(iR, iSt)
End Select
iRz = iRz + 1 'Zeilenzähler für Aushang erhöhen
End If
End If
Next iR
Next iWT
Set shAushang = Nothing
End Sub