AW: VB Editor - Codes mehrfach kopieren
05.12.2007 21:40:03
Mike
Also... es gibt 7 Tabellen, die vor der original Tabelle liegen mit den Namen Tabelle1-6.
Die 7. ist die Tabelle Übersicht.
Dann kommt die 8. Tabelle mit dem Namen Original und dann kommt der Rest.
In der Tabelle Original und im Rest steht dann folgender Code. Übrigens das meiste aus diesem Forum. Dank dafür!
Private Sub Worksheet_Activate()
Application.CommandBars("Original").Visible = True
' Call X_Funk
End Sub
Private Sub Worksheet_Deactivate()
Application.CommandBars("Original").Visible = False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, [A7]) Is Nothing Then
Range("C2").Select
End If
If Not Intersect(Target, [C1]) Is Nothing Then
With ActiveWindow
.ScrollColumn = 1
.ScrollRow = 95
End With
End If
If Not Intersect(Target, [C2]) Is Nothing Then
With ActiveWindow
.Zoom = 100
.ScrollColumn = 1
.ScrollRow = 1
End With
End If
If Not Intersect(Target, [C3]) Is Nothing Then
If Range("C3") = "" Then
Range("C3") = "A"
End If
End If
If Range("C3") = "A" Then
ActiveWorkbook.Sheets(name).Tab.ColorIndex = 3 'rot
End If
If Range("C3") = "G" Then
ActiveWorkbook.Sheets(name).Tab.ColorIndex = 35 'grün
End If
If Range("C3") = "?" Then
ActiveWorkbook.Sheets(name).Tab.ColorIndex = 36 'gelb
End If
If Range("C3") = "" Then
ActiveWorkbook.Sheets(name).Tab.ColorIndex = 40 'beige
End If
If Not Intersect(Target, [G7:G45]) Is Nothing Then
If Target.Value = "x" Then
Target.Value = ""
Else
Target.Value = "x"
Target.Offset(0, 1) = ""
Target.Offset(0, 2) = ""
End If
End If
If Not Intersect(Target, [H7:H45]) Is Nothing Then
If Target.Value = "v" Then
Target.Value = ""
Else
Target.Value = "v"
Target.Offset(0, -1) = ""
Target.Offset(0, 1) = ""
End If
End If
If Not Intersect(Target, [I7:I45]) Is Nothing Then
If Target.Value = "n" Then
Target.Value = ""
Else
Target.Value = "n"
Target.Offset(0, -2) = ""
Target.Offset(0, -1) = ""
Target.Offset(0, 1) = ""
End If
End If
If Not Intersect(Target, [J7:J45]) Is Nothing Then
If Target.Value = "x" Then
Target.Value = ""
Else
Target.Value = "x"
End If
End If
If Not Intersect(Target, [N107]) Is Nothing Then
Call UserForm_Kalender
End If
If Not Intersect(Target, [Q7:Q45]) Is Nothing Then
ActiveWindow.Zoom = 195
End If
If Not Intersect(Target, [AN115]) Is Nothing Then
If Range("AN115") = "" Then
Range("AN115") = "SK"
Else
Range("AN115") = ""
End If
End If
If Not Intersect(Target, [AN116]) Is Nothing Then
If Range("AN116") = "" Then
Range("AN116") = "FK"
Else
Range("AN116") = ""
End If
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, [A3]) Is Nothing Then
If Range("A3") = "x" Then
Range("A3") = ""
Else
Range("A3") = "x"
End If
End If
If Not Intersect(Target, [C3]) Is Nothing Then
If Range("C3") = "?" Then
Range("C3") = "G"
'---Outlook------------------------------------------------------------------------------------- _
On Error GoTo exit_sub
If MsgBox("Veranstaltung an Outlook übertragen ?", vbYesNo, "Frage !") = vbYes _
Then
Dim myOLApp As Object, myItem As Object
Set myOLApp = CreateObject("Outlook.Application")
Set myItem = myOLApp.CreateItem(1)
With myItem
'Betreff
.Subject = Range("C2").Value
'Ort
.Location = Range("G2").Value & " " & Range("G1").Value & " / " & _
Format(Range("L2").Value, "hh:mm") & " " & Range("L1").Value
'Start- & Endzeit
.start = Format(Range("B2").Value, "dd.mm.yyyy") & " " & Format(Range(" _
N2").Value, "hh:mm")
.End = Format(Range("B2").Value, "dd.mm.yyyy") & " " & Format(Range("N2" _
).Value, "hh:mm")
'Oder Endzeit in Minuten
'.Duration = "10" 'Oder True/False
'Termin Status
'.BusyStatus = olFree 'Frei
'.BusyStatus = olTentative 'Unter Vorbehalt
'.BusyStatus = olBusy 'Gebucht
'.BusyStatus = olOutOfOffice 'Abwesend
'.AllDayEvent = True 'Ganztägiges Ereignis
'Erinnerung & Zeit in Minuten & Erinnerung Sound
.ReminderSet = False
'.ReminderMinutesBeforeStart = 10
'.ReminderPlaySound = True
'Infotext
'.Body = "Veranstaltung"
'Kategorie
.Categories = "Veranstaltungen"
'Unbekannt
'.RequiredAttendees = Range("J1").Value
.Save
End With
Set myOLApp = Nothing
Set myItem = Nothing
Set apptOutApp = Nothing
Set OutApp = Nothing
MsgBox "Termine an Outlook übertragen!"
End If
exit_sub:
'---Outlook------------------------------------------------------------------------------------- _
Else
Range("C3") = "?"
End If
End If
If Not Intersect(Target, [J3]) Is Nothing Then
If Range("J3") = "" Then
Range("J3") = "0:30"
Else
Range("J3") = ""
End If
End If
If Not Intersect(Target, [L3]) Is Nothing Then
If Range("L3") = "" Then
Range("L3") = "0:30"
Else
Range("L3") = ""
End If
End If
If Not Intersect(Target, [P3]) Is Nothing Then
If Range("P3") = "" Then
Range("P3") = "0:30"
Else
Range("P3") = ""
End If
End If
Call Original
End Sub
Gruß, Mike