AW: Formelbezug, Formatierung übernehmen
27.01.2009 12:33:24
RS
Hi Dave,
Na das sieht jetzt aber schon ganz anders aus, als deine ursprüngliche Anfrage.
Darum sieht auch mein Code ganz anders aus. Kopier ihn in die Tabelle Ausdruck und lösch die anderen Codes (von oben). Ich hoffe das Coop die Preise weiterhin senken kann ;-)
Private Sub Worksheet_Calculate()
Dim lCol As Long
Dim lRow As Long
Dim lLen As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo ErrorOnMatch
For lCol = 2 To 30 Step 7
If Cells(3, lCol) = "" Then
Cells(3, lCol).Interior.ColorIndex = xlNone
Cells(3, lCol).Font.ColorIndex = xlAutomatic
Cells(3, lCol + 6).Interior.ColorIndex = xlNone
Cells(3, lCol + 6).Font.ColorIndex = xlAutomatic
Else
Select Case Left(Cells(3, lCol).Value, 1)
Case "C"
lLen = 2
Case "S"
lLen = 1
If Left(Cells(3, lCol).Value, 2) = "St" Then lLen = 2
If Left(Cells(3, lCol).Value, 3) = "Sch" Then lLen = 3
Case Else
lLen = 1
End Select
lRow = Application.WorksheetFunction.Match(Left(Cells(3, lCol).Value, lLen), _
Sheets("Farbencode").Range("A:A"), 0)
Cells(3, lCol).Interior.ColorIndex = _
Sheets("FarbenCode").Cells(lRow, 1).Interior.ColorIndex
Cells(3, lCol).Font.ColorIndex = _
Sheets("FarbenCode").Cells(lRow, 1).Font.ColorIndex
Cells(3, lCol + 6).Interior.ColorIndex = _
Sheets("FarbenCode").Cells(lRow, 1).Interior.ColorIndex
Cells(3, lCol + 6).Font.ColorIndex = _
Sheets("FarbenCode").Cells(lRow, 1).Font.ColorIndex
End If
Next lCol
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
ErrorOnMatch:
Cells(3, lCol).Interior.ColorIndex = xlNone
Cells(3, lCol).Font.ColorIndex = xlAutomatic
Cells(3, lCol + 6).Interior.ColorIndex = xlNone
Cells(3, lCol + 6).Font.ColorIndex = xlAutomatic
Resume Next
End Sub
Grüsse RS