weitere Bedingung für Übertrag
12.09.2004 17:31:21
Lorenz
lt untenstehenden CODE funktioniert alles, ausser:
die auskommentierten Bedingungen bringe ich nicht hin.
Ich probiere nun schon den zweiten Tag herum aber es will und will nicht!
vielleicht lässt sich der Code auch noch "verbessern"
hier der Code:
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
Grüsse Lorenz