Code kürzen u. umschreiben

HI CodeSpezialisten!
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.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Nepumuk!
Natürlich ist es möglich die ganze Arbeitsmappe zu übermitteln.
Sie ist umfasst aber 16MB und ist als rarFile auch noch 1,2MB gross(was den Upload meinerseits mit einem nur 56K Modem etwas langwierig werden lässt. Wenn der Download von dir ebenfalls in dieser Art stattfindet, dann erwachsen zwangsläufig höhere Kosten, für die ich selbstverständlich aufkommen würde.
Wenn das Überarbeiten meines Pfusch`s aber trotzdem gemacht oder deinerseits überarbeitet wird, so wird warscheinlich ein direkter Kontakt notwendig sein, da in diesem Excel Workbook einige verzwickte(verstrickte - verschachtelte Formeln ect. vorhanden sind)
Falls dies nicht stört, so gib mir Bitte Bescheid wohin ich das Excelfile schicken soll.
Gruss und Danke
Lorenz K.

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread