|
Ich bin dir so dankbar, dass du nicht aufgibst mir zu helfen...
Also, ich habe die Codes in der Zwischenzeit leicht abgeändert:
- Farbe der Objekte, d. h. der PLZ-Bereiche in Deutschland
- Objekte befinden sich wie die Werte, von denen sie abhängig sind, in Tabelle1
- Die Werte, von denen die Objekte abhängig sind, befinden sich in Zellen N9 bis N41, R9 bis R41 und V9 bis V41 in Tabelle1
- Zellen Y4 bis Y102 aus Tabelle2 sollen in Zellen N9 bis N41, R9 bis R41 und V9 bis V41 durch die Kopiefunktion eingefügt werden
Den folgenden Code habe ich in Tabelle1 eingefügt:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim K As Shape, roo As String, v As Variant
Dim ro, co As Integer
ro = Target.Row
co = Target.Column
v = Cells(ro, co).Value
If Target.Column = 14 And Target.Row < 42 Then
roo = LTrim(Str$(ro-8)) 'Objekt "01" verfärbt sich, wenn sich Wert in Zelle N9 ändert
If Len(roo) = 1 Then roo = "0" + roo
Set K = Me.Sapes(roo)
K.Fill.Visible = msoTrue
K.Line.Visible = msoFalse
If v <= 0.002 And v >= 0 Then
K.Fill.ForeColor.RGB = RGB(192, 0, 0)
K.OLEFormat.Object.Font.ColorIndex = 2
ElseIf v <= 0.004 And v > 0.002 Then
K.Fill.ForeColorRGB = RGB(255, 59, 59)
K.OLEFormat.Object. Font.ColorIndex = 2
ElseIf v <= 0.006 And v > 0.004 Then
K.Fill.ForeColorRGB = RGB(255, 155, 155)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.008 And v > 0.006 Then
K.Fill.ForeColorRGB = RGB(255, 192, 0)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.01 And v > 0.008 Then
K.Fill.ForeColorRGB = RGB(255, 220, 109)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.025 And v > 0.01 Then
K.Fill.ForeColorRGB = RGB(255, 233, 163)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.04 And v > 0.025 Then
K.Fill.ForeColorRGB = RGB(153, 255, 153)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.055 And v > 0.04 Then
K.Fill.ForeColorRGB = RGB(0, 222, 0)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.07 And v > 0.055 Then
K.Fill.ForeColorRGB = RGB(0, 134, 0)
K.OLEFormat.Object. Font.ColorIndex = 2
Else
K.Fill.ForeColorRGB = RGB(0, 134, 0)
K.OLEFormat.Object. Font.ColorIndex = 2
EndIf
ElseIf Target.Column = 18 And Target.Row < 42 Then
roo = LTrim(Str$(ro + 25)) 'Objekt "34" verfärbt sich, wenn sich Wert in Zelle R9 ändert
If Len(roo) = 1 Then roo = "0" + roo
Set K = Me.Sapes(roo)
K.Fill.Visible = msoTrue
K.Line.Visible = msoFalse
If v <= 0.002 And v >= 0 Then
K.Fill.ForeColor.RGB = RGB(192, 0, 0)
K.OLEFormat.Object.Font.ColorIndex = 2
ElseIf v <= 0.004 And v > 0.002 Then
K.Fill.ForeColorRGB = RGB(255, 59, 59)
K.OLEFormat.Object. Font.ColorIndex = 2
ElseIf v <= 0.006 And v > 0.004 Then
K.Fill.ForeColorRGB = RGB(255, 155, 155)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.008 And v > 0.006 Then
K.Fill.ForeColorRGB = RGB(255, 192, 0)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.01 And v > 0.008 Then
K.Fill.ForeColorRGB = RGB(255, 220, 109)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.025 And v > 0.01 Then
K.Fill.ForeColorRGB = RGB(255, 233, 163)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.04 And v > 0.025 Then
K.Fill.ForeColorRGB = RGB(153, 255, 153)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.055 And v > 0.04 Then
K.Fill.ForeColorRGB = RGB(0, 222, 0)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.07 And v > 0.055 Then
K.Fill.ForeColorRGB = RGB(0, 134, 0)
K.OLEFormat.Object. Font.ColorIndex = 2
Else
K.Fill.ForeColorRGB = RGB(0, 134, 0)
K.OLEFormat.Object. Font.ColorIndex = 2
EndIf
ElseIf Target.Column = 22 And Target.Row < 42 Then
roo = LTrim(Str$(ro + 58)) 'Objekt "67" verfärbt sich, wenn sich Wert in Zelle V9 ändert
If Len(roo) = 1 Then roo = "0" + roo
Set K = Me.Sapes(roo)
K.Fill.Visible = msoTrue
K.Line.Visible = msoFalse
If v <= 0.002 And v >= 0 Then
K.Fill.ForeColor.RGB = RGB(192, 0, 0)
K.OLEFormat.Object.Font.ColorIndex = 2
ElseIf v <= 0.004 And v > 0.002 Then
K.Fill.ForeColorRGB = RGB(255, 59, 59)
K.OLEFormat.Object. Font.ColorIndex = 2
ElseIf v <= 0.006 And v > 0.004 Then
K.Fill.ForeColorRGB = RGB(255, 155, 155)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.008 And v > 0.006 Then
K.Fill.ForeColorRGB = RGB(255, 192, 0)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.01 And v > 0.008 Then
K.Fill.ForeColorRGB = RGB(255, 220, 109)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.025 And v > 0.01 Then
K.Fill.ForeColorRGB = RGB(255, 233, 163)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.04 And v > 0.025 Then
K.Fill.ForeColorRGB = RGB(153, 255, 153)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.055 And v > 0.04 Then
K.Fill.ForeColorRGB = RGB(0, 222, 0)
K.OLEFormat.Object. Font.ColorIndex = 1
ElseIf v <= 0.07 And v > 0.055 Then
K.Fill.ForeColorRGB = RGB(0, 134, 0)
K.OLEFormat.Object. Font.ColorIndex = 2
Else
K.Fill.ForeColorRGB = RGB(0, 134, 0)
K.OLEFormat.Object. Font.ColorIndex = 2
EndIf
End If
End Sub
Den Code zum Kopieren habe ich in ein neues Modul eingefügt:
Sub Kopieren()
Dim r As Integer
For r = 4 to 36 'Zellen Y4 bis Y36 aus Tabelle2 sollen nacheinander in Zellen N9 bis N41 von Tabelle1 eingefügt werden
Tabelle2.Cells(r, 25).Copy
Tabelle1.Cells((r+5), 14).Select
Selection.PasteSpecial Paste:=xlPasteValues
Next r
For r = 37 to 69 'Zellen Y37 bis Y69 aus Tabelle2 sollen nacheinander in Zellen R9 bis R41 von Tabelle1 eingefügt werden
Tabelle2.Cells(r, 25).Copy
Tabelle1.Cells((r-23), 18).Select
Selection.PasteSpecial Paste:=xlPasteValues
Next r
For r = 70 to 102 'Zellen Y70 bis Y102 aus Tabelle2 sollen nacheinander in Zellen V9 bis V41 von Tabelle1 eingefügt werden
Tabelle2.Cells(r, 25).Copy
Tabelle1.Cells((r-56), 22).Select
Selection.PasteSpecial Paste:=xlPasteValues
Next r
End Sub
|