weitere Bedingung für Übertrag

Sub Eintrag()
Dim iBlatt, iR, iC, iRz, iCz, iSt, iSheet, iBeg, iEnd, iF2, iF6, iF7 As Integer
'Dim iBlatt, iR, iC,(QuellTabelle) iRz, iCz,(ZielTabelle) iSt, iSheet, iBeg, iEnd, iF2, iF6, iF7 As Integer
iStrecke = 2
Set iSheet = Sheets("Blatt" & iBlatt)
With iSheet
.Range("a5:u24").ClearContents
.Cells(1, 9).Value = ActiveSheet.Cells(5, 3) + ActiveCell.Text - 1
End With
iBeg = 6
iEnd = 83
iRz = 5
iCz = 2
iC = 3
iSt = ActiveCell.Column + 1
iF2 = 15
iF6 = 34
iF7 = 36
For iR = iBeg To iEnd
If Cells(iR, iSt - 1) = "K" Or Cells(iR, iSt - 1) = "U" Then GoTo WeiterMo
If Cells(iR, iSt) <> "" And Cells(iR, iSt).Interior.ColorIndex = iF2 _
Or Cells(iR, iSt - 1) <> "" And Cells(iR, iSt - 1).Interior.ColorIndex = iF2 Then
With iSheet
.Cells(iRz, iCz) = Cells(iR, iC)
.Cells(iRz, iCz - 1) = Cells(iR, iSt - 1)
End With
iRz = iRz + 1
WeiterMo:   If Cells(iR, iSt) > "" And Cells(iR, iSt).Interior.ColorIndex = iF2 Then
iSheet.Cells(iRz - 1, iCz + 1) = Cells(iR, iSt)
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Das ist der Bereich den ich nicht schaffe:
'If Cells(iR, iSt) > "" And Cells(iR, iSt).Interior.ColorIndex = iF6 Then
'         iSheet.Cells(iRz - 1, iCz + 1) = "6"
'ElseIf Cells(iR, iSt) > "" And Cells(iR, iSt).Interior.ColorIndex = iF7 Then
'         iSheet.Cells(iRz - 1, iCz + 1) = "7"
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
If Cells(iR, iSt) = "o" And Cells(iR, iSt).Interior.ColorIndex = iF2 Then
iSheet.Cells(iRz - 1, iCz + 1) = "V6"
ElseIf Cells(iR, iSt) = "O" And Cells(iR, iSt).Interior.ColorIndex = iF2 Then
iSheet.Cells(iRz - 1, iCz + 1) = "V8"
Else: iSheet.Cells(iRz - 1, iCz + 1) = Cells(iR, iSt)
End If
End If
End If
Next
End Sub