Code Bediengte formatierung

Question

Hallo,

habe mal eine frage zum folgen Code

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rngZelle As Range, strText As String
Select Case Target.Value
Case "U"
Target.Interior.ColorIndex = 6
Case "u"
Target.Interior.ColorIndex = 6
Case "H"
Target.Interior.ColorIndex = 36
Case "h"
Target.Interior.ColorIndex = 36
Case ""
Target.Interior.ColorIndex = 0
End Select
End Sub

der Code funktioniert wenn man die Buchstaben einzeln in die Zellen eingibt wenn man aber die erste Zelle nach unten zieht kommt eine fehlermeldung " Laufzeitfehler 13 Typen unverträglich "

grüße
Achim

Answer 1

Hallo Achim,

probier's mal so

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rngZelle As Range, strText As String
On Error Resume Next
Select Case Target.Value
Case "U"
Target.Interior.ColorIndex = 6
Case "u"
Target.Interior.ColorIndex = 6
Case "H"
Target.Interior.ColorIndex = 36
Case "h"
Target.Interior.ColorIndex = 36
Case ""
Target.Interior.ColorIndex = 0
End Select
End Sub


Feedback wäre nett
Gruss Rainer
_____________________
Windows 7 Ultimate (x64)
Office 2007 Ultimate
Office 2003 Professional

Answer 2

Hallo Rainer,

danke schön, das wars.

Grüße und noch einen schönen Abend
Achim

Answer 3

Hi Achim,

On Error Resume Next sollte man nur dann anwenden, wenn es nicht anders geht (oder wenn man damit gezielt etwas bestimmtes erreichen will). Im gegebenen Fall ist es jedoch nicht erforderlich. Außerdem wird die Füllfarbe nicht zurückgesetzt, wenn du einen aus mehreren Zellen bestehenden gefärbten Bereich löschst.

Hier eine Lösung, die beides umgeht:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rngZelle As Range
If Target.Count = 1 Then
Select Case Target
Case "U", "u"
Target.Interior.ColorIndex = 6
Case "H", "h"
Target.Interior.ColorIndex = 36
Case ""
Target.Interior.ColorIndex = 0
End Select
Else
For Each rngZelle In Selection
Select Case rngZelle
Case "U", "u"
Target.Interior.ColorIndex = 6
Case "H", "h"
Target.Interior.ColorIndex = 36
Case ""
Target.Interior.ColorIndex = 0
End Select
Next rngZelle
End If
End Sub

Bis später,
Karin

Answer 4

Hallo Karin,
danke schön, das funktioniert noch besser.

Jetzt habe ich noch ein paar fragen und zwar habe ich deinen Code in " Diese Arbeitsmappe " kopiert was auch so weit funktioniert das problem was sich jetzt aufgetan hat, ist das sobald ich in den Tabellen1 bis Tabelle4 ( der Tabellen Name kann sich ändern ) was eingebe wird auch der folgende Code ausgeführt der in den " Tabellen " eingefügt ist

Code in den Tabellen:
Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address = "$AI$1" Then
Application.ScreenUpdating = False

'Blattname wird erstellt
ActiveSheet.Name = Range("aq1").Value

'Button ausblenden April

If Range("B5") = 1 Then CommandButton1.Visible = True
If Range("B5") = 2 Then CommandButton1.Visible = False
If Range("B6") = 1 Then CommandButton2.Visible = True
If Range("B6") = 2 Then CommandButton2.Visible = False
.
.
.


kann man auch den Bereich bei deinen Code festlegen, wo eben nur eine eingabe erfolgen darf ( der Bereich wär H5 : AP35 )

grüße
Achim

Answer 5

Hi Achim,

versuche es mal so:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
For Each Target In Selection
If Not Intersect(Target, Range("H5:AP35")) Is Nothing Then
Select Case Target
Case "U", "u"
Target.Interior.ColorIndex = 6
Case "H", "h"
Target.Interior.ColorIndex = 36
Case ""
Target.Interior.ColorIndex = 0
End Select
End If
Next Target
End Sub

Answer 6

Hallo,

muß leider sagen das funktioniert auch nicht, denke mal es liegt an den den beiden Code´s sind nur auszüge

Code in DieseArbeitsmappe:

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rngZelle As Range
Dim isect As Range

Set isect = Application.Intersect(ActiveCell, Range("h5: ap35"))
If Not isect Is Nothing Then

If Target.Count = 1 Then
Select Case Target
Case "U", "u"
Target.Interior.ColorIndex = 6
Case "H", "h"
Target.Interior.ColorIndex = 36

Code in Tabelle:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Target.Address = "$AI$1" Then

'Blattname wird erstellt
ActiveSheet.Name = Range("aq1").Value

'Button ausblenden Januar
Application.ScreenUpdating = False
If Range("B5") = 1 Then CommandButton1.Visible = True
If Range("B5") = 2 Then CommandButton1.Visible = False
If Range("B6") = 1 Then CommandButton2.Visible = True

das probblem ist nun sobald ich was in den Zellen h5:ap35 eingebe wird auch der VBA Code von der Tabelle ausgeführt, was nicht sein darf.

Der VBA Code in der Tabelle soll nur ausgeführt werden wenn in der Tabelle1 Zelle ai1 eine eingabe erfolgt und der Code in Dieser Arbeitsmappe soll nur ausgeführt werden bei einer Zellen eingabe von h5:ap35 in der ganzen Mappe.

grüße
Achim

Answer 7

Hi Achim,

dein Code unter DieseArbeitsmappe sieht anders aus als der den ich gepostet habe.

Ich habe jetzt zum Testen im Codemodul DieseArbeitsmappe meinen geposteten Code und ins Codemodul der Tabelle1 diesen simplen Code eingefügt:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
MsgBox "Hallo"
End If
End Sub

Wenn ich jetzt in Tabelle1 im Bereich H5:AP35 etwas eintrage, müsste deinem Beitrag zufolge die MsgBox erscheinen. Testergebnis: tut sie nicht - weshalb sollte sie denn auch, es wird ja im Tabellenblatt ein völlig anderer Bereich, und zwar Zelle A1 und nicht H5:AP35, angesprochen. Wenn du einen Haltepunkt auf die Prozedur im Codemodul des Tabellenblattes setzt, wirst du sehen, dass der Code sofort von If zu End If geht.

Bis später,
Karin

Answer 8

Hallo Karin,


habe jetzt einmal die Datei Hochgeladen

http://www.file-upload.net/download-3059153/Urlaubsplan-Vorlage-farben.xls.html

gehe bitte dann einmal auf Qaurtal I 2011 und gebe mal in Zelle h5 ein "U" ein.

Wäre dir dankbar wenn du mir dabei helfen könntest.


grüße
Achim

Answer 9

Hi Achim,

dein Code ist sehr umfangreich und leider ziemlich unübersichtlich weil unstrukturiert geschrieben, was es schwer macht, den Anfang und das Ende der einzelnen Abschnitte korrekt festzustellen.
Schreibe allen Code ins Codemodul jeder Tabelle, nach diesem Prinzip:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Target.Address = "$AI$1" Then
' hier dein gesamter restlicher Code, also alles das was
' bei Eintrag in AI1 ausgeführt werden soll
' .......
CommandButton185.Caption = ActiveSheet.Range("ae34").text
CommandButton186.Caption = ActiveSheet.Range("ae35").text
' Daten Kopieren
Application.Run "jahrkopieren2"
Application.Run "jahrkopieren3"
Application.Run "jahrkopieren4"

ElseIf Not Intersect(Target, Range("H5:AP35")) Is Nothing Then
Dim rngZelle As Range
If Target.Count = 1 Then
Select Case Target
Case "U", "u"
Target.Interior.ColorIndex = 6
Case "H", "h"
Target.Interior.ColorIndex = 36
Case ""
Target.Interior.ColorIndex = 0
End Select
Else
For Each rngZelle In Selection
Select Case rngZelle
Case "U", "u"
Target.Interior.ColorIndex = 6
Case "H", "h"
Target.Interior.ColorIndex = 36
Case ""
Target.Interior.ColorIndex = 0
End Select
Next rngZelle
End If
Else
' und hier alles das rein, was ausgeführt werden soll wenn weder in A1 noch
' in H5:AP35 etwas eingetragen wird
End If
Application.ScreenUpdating = True
End Sub

Du könntest deinen Code wesentlich vereinfachen bzw. verkürzen, wenn du die Schalter mit jeweils nur 1 Codezeile ein- bzw. ausblendest:

CommandButton1.Visible = Range("B5") = 1
CommandButton2.Visible = Range("B6") = 1
CommandButton3.Visible = Range("B7") = 1
CommandButton4.Visible = Range("B8") = 1
CommandButton5.Visible = Range("B9") = 1
CommandButton6.Visible = Range("B10") = 1

usw.

Bis später,
Karin

Answer 10

Hallo Karin,

also bin nun wirklich kein Profi in solchen sachen, Probiere halt sehr viel aus, aber nun zu den Code bei der folgenden Zeile kommt eine fehler Meldung

ElseIf Not Intersect(Target, Range("H5:AP35")) Is Nothing Then

Fehler bim Komilieren:
Esle ohne If

sorry finde aber den fehler nicht.

Dachte mir schon das man das ganze ein wenig änden kann. :-)

grüße
Achim