Hallo Excel Freunde,
Ich habe ein Problem mit dem Weiterschalten der farbhinterlegten Zellinhalte. Und zwar habe ich in der Spalte D, D1:D12 und in der neben stehende Tabelle E6:F6 mit Daten gefüllt, die mit Klick auf Makro3 den Zellinhalt mit 2 Felder farbig hinterlegen. Nun möchte jetzt mit dem Makro2 die gekennzeichneten Zellinhalte mit der hinterlegten Farbmarkierung weiter schalten, sowie in der Spalte D und der neben stehende Tabelle. Danke und Gruß Kallie
Option Explicit
Sub Makro1()
' Hinweis: Die Spalte müssen erst ausgefüllt werden
' in Spalte A und Spalte X stehen die gleichen Zahlen von 1 bis 12
' in Spalte V stehen 2 Zahlen, 2 , 11
Range("B6,A1:A12,C1:C12").Interior.ColorIndex = xlNone 'ohne Farbe
Range("A1:A12") = Range("X1:X12").Value
End Sub
Sub Makro2()
Dim arrV As Variant, intNr As Integer
Dim ii As Integer, jj As Integer, kk As Integer, varW As Variant
arrV = Application.Transpose(Range("C1:C25")) ' 4 Zeichen in D1:D4
intNr = IIf(Cells(22, 10) < 12, Cells(22, 10) + 1, 1) ' Nr in Zelle I25 + 1
For ii = 1 To intNr
jj = jj + 1
For kk = 1 To jj
If kk = 1 Then
varW = arrV(kk)
arrV(kk) = arrV(kk + 1)
ElseIf kk < 12 Then
arrV(kk) = arrV(kk + 1)
End If
Next
arrV(jj) = varW
If kk > 12 Then jj = 1
Next ii
Range("C1:C12") = Application.Transpose(arrV) ' Ausgabe in E1:F7
Range("E1:E6") = Range("C1:C6").Value
Range("F1:F6") = Range("C7:C12").Value
Range("G27").Select
Cells(22, 10) = intNr ' neue Nr in J22
Erase arrV
End Sub
Sub Makro3()
Range("B6,N22,A1:A12").Interior.ColorIndex = xlNone 'ohne Farbe
Range("V1:V2").Copy
Range("N22").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
'aktuelle KW suchen
Dim strSuch As Integer
Dim lngAnz
strSuch = Range("N22").Value
lngAnz = WorksheetFunction.CountIf(Range("A1:A12"), strSuch)
Range("A1:A12").Find(What:=strSuch, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False).Activate
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
'aktuelle KW suchen
strSuch = Range("O22").Value
lngAnz = WorksheetFunction.CountIf(Range("A1:A12"), strSuch)
Range("A1:A12").Find(What:=strSuch, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False).Activate
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Range("A1:A12").Copy
Range("C1").PasteSpecial , Paste:=xlPasteFormats
Application.CutCopyMode = False
Range("G27").Select
End Sub