Excel VBA Makro in allen Tabellenblättern verfügbar machen

[cocosmuc]

Servus!

Ich habe eine Excel-Mappe mit vielen Tabellenblättern, und über "Code anzeigen" ein VBA-Makro in vorerst EINES der Blätter eingefügt.

Da funktioniert es auch. Logischerweise auf den anderen erstmal nicht... 

Wie kann ich jetzt dieses Stück Code auf allen Blättern verfügbar machen, ohne dass ich es überall hinkopiere?

Hier mein Code:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A22:A41")) Is Nothing Then
    Target(1, 2).ClearContents
    Target(1, 3).ClearContents
    Target(1, 1).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("A1:B99"), 2, 0)
    Target(1, 2).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("B1:D99"), 3, 0)
    Target(1, 3).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("B1:C99"), 2, 0)
End If
If Not Intersect(Target, Range("B22:B41")) Is Nothing Then
    Target(1, 0).ClearContents
    Target(1, 2).ClearContents
    Target(1, 0).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("D1:E99"), 2, 0)
    Target(1, 2).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("D1:F99"), 3, 0)
End If
If Not Intersect(Target, Range("C22:C41")) Is Nothing Then
    Target(1, -1).ClearContents
    Target(1, 0).ClearContents
    Target(1, -1).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("C1:E99"), 3, 0)
    Target(1, 0).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("C1:D99"), 2, 0)
End If
errHandler:
On Error GoTo 0
Application.EnableEvents = True
End Sub

Ich hoffe die frage ist verständlich... 

[Glausius]

Hallo,
änder den Namen der Sub ab in:

Private Sub Workbook_SheetChange(ByVal Sh As Objekt,ByVal Target As Range)

und kopiere den ganzen Code in DieseArbeitsmappe.

[cocosmuc]

Schade, das hat nicht funktioniert.

Also, ich habe den Code in "This Workbook" verschoben und die Private Sub...-Zeile geändert. Jetzt geht es in keinem Tabellenblatt mehr

Nun sieht es so aus wie im Attachment und der Code so:

Code:

Private Sub Workbook_SheetsActivate(ByVal Sh As Objekt)
' Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A22:A41")) Is Nothing Then
    Target(1, 2).ClearContents
    Target(1, 3).ClearContents
    Target(1, 1).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("A1:B99"), 2, 0)
    Target(1, 2).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("B1:D99"), 3, 0)
    Target(1, 3).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("B1:C99"), 2, 0)
End If
If Not Intersect(Target, Range("B22:B41")) Is Nothing Then
    Target(1, 0).ClearContents
    Target(1, 2).ClearContents
    Target(1, 0).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("D1:E99"), 2, 0)
    Target(1, 2).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("D1:F99"), 3, 0)
End If
If Not Intersect(Target, Range("C22:C41")) Is Nothing Then
    Target(1, -1).ClearContents
    Target(1, 0).ClearContents
    Target(1, -1).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("C1:E99"), 3, 0)
    Target(1, 0).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("C1:D99"), 2, 0)
End If
errHandler:
On Error GoTo 0
Application.EnableEvents = True

End Sub

Was mach ich falsch?

[Glausius]

Hallo,

schau bitte noch einmal genau in meinen Beitrag, der Name der Sub muss geändert werden!

Und was ist denn falsch?

[cocosmuc]

Aber ich hab doch den Namen des Sub geändert (und meinen alten auskommentiert). 
Jetzt lösch ich mal die Kommentarzeile, dann bleibt folgendes übrig, in "ThisWorkbook":

Code:

Private Sub Workbook_SheetsChange(ByVal Sh As Objekt, ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A22:A41")) Is Nothing Then
   Target(1, 2).ClearContents
   Target(1, 3).ClearContents
   Target(1, 1).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("A1:B99"), 2, 0)
   Target(1, 2).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("B1:D99"), 3, 0)
   Target(1, 3).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("B1:C99"), 2, 0)
End If
If Not Intersect(Target, Range("B22:B41")) Is Nothing Then
   Target(1, 0).ClearContents
   Target(1, 2).ClearContents
   Target(1, 0).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("D1:E99"), 2, 0)
   Target(1, 2).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("D1:F99"), 3, 0)
End If
If Not Intersect(Target, Range("C22:C41")) Is Nothing Then
   Target(1, -1).ClearContents
   Target(1, 0).ClearContents
   Target(1, -1).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("C1:E99"), 3, 0)
   Target(1, 0).Value = WorksheetFunction.VLookup(Target(1, 1).Value, Tabelle2.Range("C1:D99"), 2, 0)
End If
errHandler:
On Error GoTo 0
Application.EnableEvents = True

End Sub

Aber auf dem Tabellenblatt, in dem der Code vorher stand - und jetzt nicht mehr - funktioniert das Makro nicht mehr.

Irgendwo steh ich aufm Schlauch, bloß wo?

[RPP63]

Ist das jetzt hier heiteres Ereignismakro-raten?
http://www.online-excel.de/excel/singsel_vba.php?f=160
könnte helfen, wilde Raterei zu verhindern.

Das Dingens heißt immer noch
Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Gruß Ralf

[cocosmuc]

YESS!

{Ups, schon wieder ein S zu viel... also:}

YES! Das "s" hab ich auch übersehen!

Danke  :100: