Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Label
BildScreenshot zu Label Label-Seite mit Beispielarbeitsmappe aufrufen

VB Editor - Codes mehrfach kopieren

Betrifft: VB Editor - Codes mehrfach kopieren von: Mike
Geschrieben am: 05.12.2007 20:36:11

Hallo zusammen.

Leider hat meine suche keinen Erfolg gehabt.

Ich habe eine Arbeitsmappe mit ca. 80 Blättern. Eine Original Mappe und der Rest sind kopien vom Original.

Ich möchte nun den VB Code des originalen Tabellenblattes in die restlichen TB kopieren,
ohne jedes einzelne TB dabei anzuklicken und den Code dann per Hand einzufügen.

Was für eine Möglichkeit gibt es, den originalen Code in die restlichen TB zu kopieren?

Dank voraus! Gruß, Mike

  

Betrifft: AW: VB Editor - Codes mehrfach kopieren von: Josef Ehrensberger
Geschrieben am: 05.12.2007 20:38:14

Hallo Mike,

80 mal den gleichen Code?

Warum packst du dann den Code nicht in die entsprechende Prozedur(en) unter "DieseArbeitsmappe" ?


Gruß Sepp



  

Betrifft: AW: VB Editor - Codes mehrfach kopieren von: Mike
Geschrieben am: 05.12.2007 21:17:25

Hi Sepp.

Danke für Deine Antwort.

Ich wüsste nicht, wie ich dies bewerkstelligen soll?

Gruß, Mike


  

Betrifft: AW: VB Editor - Codes mehrfach kopieren von: Josef Ehrensberger
Geschrieben am: 05.12.2007 21:28:18

Hallo Mike,

zeig doch mal den Code den du in deiner Tabelle stehen hast.

Soll der Code in allen Tabellen der Mappe gelten, oder gibt es Tabellen in denen der Code nicht laufen soll?
Wenn ja, wie sind die Namen der Tabellen?


Gruß Sepp



  

Betrifft: AW: VB Editor - Codes mehrfach kopieren von: Mike
Geschrieben am: 05.12.2007 21:40:03

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


  

Betrifft: AW: VB Editor - Codes mehrfach kopieren von: Josef Ehrensberger
Geschrieben am: 05.12.2007 22:03:06

Hallo Mike,

probier mal. Zuerst den Code in den Tabellen auskommentieren oder löschen.

Diesen Code unter "DieseArbeitsmappe" einfügen. Die Tabellennamen in der Funktion "CheckSheet" anpassen!

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Workbook_SheetActivate(ByVal sh As Object)
If Not CheckSheet(sh.Name) Then Exit Sub

Application.CommandBars("Original").Visible = True
' Call X_Funk
End Sub

Private Sub Workbook_SheetDeactivate(ByVal sh As Object)
If Not CheckSheet(sh.Name) Then Exit Sub

Application.CommandBars("Original").Visible = False
End Sub

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
If Not CheckSheet(sh.Name) Then Exit Sub

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
    sh.Tab.ColorIndex = 3 'rot
End If
If Range("C3") = "G" Then
    sh.Tab.ColorIndex = 35 'grün
End If
If Range("C3") = "?" Then
    sh.Tab.ColorIndex = 36 'gelb
End If
If Range("C3") = "" Then
    sh.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

Private Function CheckSheet(ByVal shName As String) As Boolean
Dim vSheets As Variant

'Hier alle Tabellennamen eintragen in denen der Code NICHT laufen soll!
vSheets = Array("Tabelle1", "Tabelle2", "Tabelle3", "Tabelle4", _
    "Tabelle5", "Tabelle6", "Übersicht")

CheckSheet = Not IsNumeric(Application.Match(shName, vSheets, 0))
End Function

Gruß Sepp



  

Betrifft: AW: VB Editor - Codes mehrfach kopieren von: Mike
Geschrieben am: 05.12.2007 22:25:05

So... habe aus allen Tabellen den Code gelöscht. Dann den Code in "Diese Arbeitsmappe" kopiert, Datei gespeichert und neu gestartet.

Aber nix Passiert :-(

Gruß, Mike


  

Betrifft: Tabellennamen angepasst? von: Josef Ehrensberger
Geschrieben am: 05.12.2007 22:32:23

Gruß Sepp



  

Betrifft: AW: Tabellennamen angepasst? von: Mike
Geschrieben am: 05.12.2007 22:42:22

ja klar...!


  

Betrifft: AW: Tabellennamen angepasst? von: Josef Ehrensberger
Geschrieben am: 05.12.2007 22:45:35

Hallo Mike,

schreib mal ins Direktfenster "Application.EnableEvents = True" und drücke dann Enter.


Gruß Sepp



  

Betrifft: AW: Tabellennamen angepasst? von: Mike
Geschrieben am: 05.12.2007 22:53:35

Hi Sepp.

Hab ich gemacht. Was soll passieren?

Gruß, Mike


  

Betrifft: AW: Tabellennamen angepasst? von: Josef Ehrensberger
Geschrieben am: 05.12.2007 23:02:00

Hallo Mike,

ich dachte das du vielleicht irgendwie die Ereignissüberwachung deaktiviert hast.

Also bei mir funktioniert der Code, ich weiss allerdings nicht, was in deiner Datei sonst noch alles drinn ist.


Gruß Sepp



  

Betrifft: AW: Tabellennamen angepasst? von: Mike
Geschrieben am: 05.12.2007 23:14:11

Hi Sepp.

Habs jetzt mal in einer neuen Arbeitsmappe versucht. Klappt aber auch nicht?

Gruß, Mike


  

Betrifft: AW: Tabellennamen angepasst? Problem gelößt! von: Mike
Geschrieben am: 06.12.2007 12:06:27


Hi Sepp.

Ich möchte mich nochmals für Deine Hilfe und Deine Anregung bedanken.

Ich habe mein Problem lösen können. Da ich diese möglichkeit nicht kannte, musste ich mich erst einmal einlesen.

Dein Code begann mit

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)


Meine Codes liefen aber mit der Methode


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
und...
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


gelösßt habe ich es jetzt so


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
und...
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel  _
As Boolean)


Der Rest Deines Codes läuft Super. Danke Dir dafür!

Schöne Weihnachtsfeiertage und lass Dich reich beschenken! :-)

Gruß, Mike


 

Beiträge aus den Excel-Beispielen zum Thema "VB Editor - Codes mehrfach kopieren"