Code kürzen u. umschreiben
29.11.2003 15:26:27
Lorenz K
1.Bitte Bitte wer kann diesen Durcheinander Ordnen, schlichten u. kürzen, ist alles aus verschiedensten Quellen zusammengewürfelt
2. Ich verwende folgende CODE`S in Insgesamt 31 Sheets!
Ist es bzw. wie ist es möglich mit nur einmal-eintrag in Modul oder aus einem Blatt zuzugreifen.
CODE`s u. SUB`s:
Private Sub Worksheet_Activate()
StartSel
Range("be4").Value = "ND"
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Sheets("Zeit").Visible = xlHidden
Dim oBar As CommandBar
Dim oBtn As CommandBarButton
Dim wks As Worksheet
Dim iCol As Integer
If Target.Row > 6 And Target.Row <= 89 Then
If Target.Column = 5 Or Target.Column = 6 Or _
Target.Column = 8 Or Target.Column = 9 Or _
Target.Column = 11 Or Target.Column = 12 Then _
Set wks = Worksheets("Zeit")
Call DeleteCmdBar
Set oBar = Application.CommandBars.Add( _
Name:="StringInsert", _
Position:=msoBarPopup, _
MenuBar:=False, _
temporary:=True)
iCol = 1
Do Until IsEmpty(wks.Cells(1, iCol))
Set oBtn = oBar.Controls.Add
With oBtn
.Caption = wks.Cells(1, iCol).Value
.Style = msoButtonCaption
.OnAction = "GetValue"
End With
iCol = iCol + 1
Loop
CommandBars("StringInsert").ShowPopup
Sheets("Zeit").Visible = xlVeryHidden
Cancel = True
End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
Call SummenMenue
'Cancel = True
End Sub
Private Sub ToggleButton1_Change()
If ToggleButton1.Value = False Then
ToggleButton1.Caption = "ausblenden"
Call NachtZweiHer
ElseIf ToggleButton1.Value = True Then
ToggleButton1.Caption = "2. Nacht"
Call NachtZweiWeg
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim BereichArt1, BereichArt2, BereichArt3, BereichArt4, BereichV8, BereichU As Range
Dim BereichTag1, BereichTag2 As Range
Set BereichTag1 = Range("dt233:dt367")
Set BereichTag2 = Range("du233:du367")
Set BereichArt1 = Range("g6:g89")
Set BereichArt2 = Range("j6:j89")
Set BereichArt3 = Range("m6:m89")
Set BereichArt4 = Range("q6:r89")
Set BereichV8 = Range("o6:o89")
Set BereichU = Range("x6:x89")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
If Target.Row > 6 And Target.Row <= 89 Then
On Error GoTo Fehlerbehandlung
If Target.Column = 6 Then
Range(Cells(6, 7), Cells(6, 7)).Copy Cells(Target.Row, 7)
For Each Zelle In BereichArt1
If Zelle.HasFormula Then Zelle.Calculate
Next
Range(Cells(6, 59), Cells(6, 60)).Copy Cells(Target.Row, 59)
Range(Cells(6, 63), Cells(6, 64)).Copy Cells(Target.Row, 63)
Range(Cells(6, 67), Cells(6, 68)).Copy Cells(Target.Row, 67)
Range(Cells(6, 71), Cells(6, 72)).Copy Cells(Target.Row, 71)
Range(Cells(6, 75), Cells(6, 76)).Copy Cells(Target.Row, 75)
Range(Cells(6, 79), Cells(6, 80)).Copy Cells(Target.Row, 79)
Range(Cells(6, 83), Cells(6, 84)).Copy Cells(Target.Row, 83)
Range(Cells(6, 87), Cells(6, 88)).Copy Cells(Target.Row, 87)
Range(Cells(6, 91), Cells(6, 92)).Copy Cells(Target.Row, 91)
Range(Cells(6, 95), Cells(6, 96)).Copy Cells(Target.Row, 95)
Range(Cells(6, 99), Cells(6, 100)).Copy Cells(Target.Row, 99)
Range(Cells(6, 103), Cells(6, 104)).Copy Cells(Target.Row, 103)
Range(Cells(6, 159), Cells(6, 160)).Copy Cells(Target.Row, 159)
End If
If Target.Column = 9 Then
Range(Cells(6, 10), Cells(6, 10)).Copy Cells(Target.Row, 10)
For Each Zelle In BereichArt2
If Zelle.HasFormula Then Zelle.Calculate
Next
Range(Cells(6, 59), Cells(6, 60)).Copy Cells(Target.Row, 59)
Range(Cells(6, 63), Cells(6, 64)).Copy Cells(Target.Row, 63)
Range(Cells(6, 67), Cells(6, 68)).Copy Cells(Target.Row, 67)
Range(Cells(6, 71), Cells(6, 72)).Copy Cells(Target.Row, 71)
Range(Cells(6, 75), Cells(6, 76)).Copy Cells(Target.Row, 75)
Range(Cells(6, 79), Cells(6, 80)).Copy Cells(Target.Row, 79)
Range(Cells(6, 83), Cells(6, 84)).Copy Cells(Target.Row, 83)
Range(Cells(6, 87), Cells(6, 88)).Copy Cells(Target.Row, 87)
Range(Cells(6, 91), Cells(6, 92)).Copy Cells(Target.Row, 91)
Range(Cells(6, 95), Cells(6, 96)).Copy Cells(Target.Row, 95)
Range(Cells(6, 99), Cells(6, 100)).Copy Cells(Target.Row, 99)
Range(Cells(6, 103), Cells(6, 104)).Copy Cells(Target.Row, 103)
Range(Cells(6, 159), Cells(6, 160)).Copy Cells(Target.Row, 159)
End If
If Target.Column = 12 Then
Range(Cells(6, 13), Cells(6, 13)).Copy Cells(Target.Row, 13)
For Each Zelle In BereichArt3
If Zelle.HasFormula Then Zelle.Calculate
Next
Range(Cells(6, 59), Cells(6, 60)).Copy Cells(Target.Row, 59)
Range(Cells(6, 63), Cells(6, 64)).Copy Cells(Target.Row, 63)
Range(Cells(6, 67), Cells(6, 68)).Copy Cells(Target.Row, 67)
Range(Cells(6, 71), Cells(6, 72)).Copy Cells(Target.Row, 71)
Range(Cells(6, 75), Cells(6, 76)).Copy Cells(Target.Row, 75)
Range(Cells(6, 79), Cells(6, 80)).Copy Cells(Target.Row, 79)
Range(Cells(6, 83), Cells(6, 84)).Copy Cells(Target.Row, 83)
Range(Cells(6, 87), Cells(6, 88)).Copy Cells(Target.Row, 87)
Range(Cells(6, 91), Cells(6, 92)).Copy Cells(Target.Row, 91)
Range(Cells(6, 95), Cells(6, 96)).Copy Cells(Target.Row, 95)
Range(Cells(6, 99), Cells(6, 100)).Copy Cells(Target.Row, 99)
Range(Cells(6, 103), Cells(6, 104)).Copy Cells(Target.Row, 103)
Range(Cells(6, 159), Cells(6, 160)).Copy Cells(Target.Row, 159)
End If
If Target.Column = 14 Then
Range(Cells(6, 15), Cells(6, 15)).Copy Cells(Target.Row, 15)
For Each Zelle In BereichV8
If Zelle.HasFormula Then Zelle.Calculate
Next
Range(Cells(6, 58), Cells(6, 58)).Copy Cells(Target.Row, 58)
Range(Cells(6, 62), Cells(6, 62)).Copy Cells(Target.Row, 62)
Range(Cells(6, 66), Cells(6, 66)).Copy Cells(Target.Row, 66)
Range(Cells(6, 70), Cells(6, 70)).Copy Cells(Target.Row, 70)
Range(Cells(6, 74), Cells(6, 74)).Copy Cells(Target.Row, 74)
Range(Cells(6, 78), Cells(6, 78)).Copy Cells(Target.Row, 77)
Range(Cells(6, 82), Cells(6, 82)).Copy Cells(Target.Row, 82)
Range(Cells(6, 86), Cells(6, 86)).Copy Cells(Target.Row, 86)
Range(Cells(6, 90), Cells(6, 90)).Copy Cells(Target.Row, 90)
Range(Cells(6, 94), Cells(6, 94)).Copy Cells(Target.Row, 94)
Range(Cells(6, 98), Cells(6, 98)).Copy Cells(Target.Row, 98)
Range(Cells(6, 102), Cells(6, 102)).Copy Cells(Target.Row, 102)
End If
'vonbisNacht
If Target.Column = 16 Then
Range(Cells(6, 18), Cells(6, 18)).Copy Cells(Target.Row, 18)
For Each Zelle In BereichArt4
If Zelle.HasFormula Then Zelle.Calculate
Next
Range(Cells(6, 59), Cells(6, 60)).Copy Cells(Target.Row, 59)
Range(Cells(6, 63), Cells(6, 64)).Copy Cells(Target.Row, 63)
Range(Cells(6, 67), Cells(6, 68)).Copy Cells(Target.Row, 67)
Range(Cells(6, 71), Cells(6, 72)).Copy Cells(Target.Row, 71)
Range(Cells(6, 75), Cells(6, 76)).Copy Cells(Target.Row, 75)
Range(Cells(6, 79), Cells(6, 80)).Copy Cells(Target.Row, 79)
Range(Cells(6, 83), Cells(6, 84)).Copy Cells(Target.Row, 83)
Range(Cells(6, 87), Cells(6, 88)).Copy Cells(Target.Row, 87)
Range(Cells(6, 91), Cells(6, 92)).Copy Cells(Target.Row, 91)
Range(Cells(6, 95), Cells(6, 96)).Copy Cells(Target.Row, 95)
Range(Cells(6, 99), Cells(6, 100)).Copy Cells(Target.Row, 99)
Range(Cells(6, 103), Cells(6, 104)).Copy Cells(Target.Row, 103)
Range(Cells(6, 159), Cells(6, 160)).Copy Cells(Target.Row, 159)
End If
If Target.Column = 22 Then
Range(Cells(6, 24), Cells(6, 24)).Copy Cells(Target.Row, 24)
For Each Zelle In BereichU
If Zelle.HasFormula Then Zelle.Calculate
Next
Range(Cells(6, 105), Cells(6, 107)).Copy Cells(Target.Row, 105)
End If
If Target.Column = 55 Then
Range(Cells(6, 249), Cells(6, 256)).Copy Cells(Target.Row, 249)
End If
If Target.Column = 40 Then
Range(Cells(6, 144), Cells(6, 150)).Copy Cells(Target.Row, 144)
End If
End If
Fehlerbehandlung:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
On Error Resume Next
Application.CommandBars("Cell").Controls("Summen zur Kontrolle").Delete
If Target.Row >= 6 And Target.Row <= 89 And Target.Column = 1 Then _
Rows(Target.Row).Select
End Sub
Private Sub SummenMenue()
Dim oBtn As CommandBarButton
On Error Resume Next
Application.CommandBars("Cell") _
.Controls("Notiz bearbeiten").Delete
On Error GoTo 0
Set oBtn = CommandBars("Cell").Controls.Add
With oBtn
.Caption = "Summen zur Kontrolle"
.OnAction = "TagSumme"
.Style = msoButtonCaption
End With
End Sub
Danke im voraus Lorenz K.