Wir möchten alle rot farbigen Zeilen EINMAL aus Tabelle1 in Tabelle2 kopieren. Die Tabelle2 soll vorher geleert werden.
Unsere Problematik ist, dass in manchen Zeilen mehrere Zellen rot sind und somit doppelt in Tabelle 2 auftauchen.
Hier unser Code:
__________
Sub FarbigeZeileKopieren()
Dim Bereich As Range, c As Range, i As Long
Dim SpaltenArray() As Integer
Set Bereich = Range(„A3:J1720“)
Worksheets(„Tabelle2“).Range(„A1:J1720“).CurrentRegion.Clear
For Each c In Bereich
If c.Font.ColorIndex = 3 Then
i = i + 1
Range(„A“ & c.Row & „:J“ & c.Row).Copy Sheets(„Tabelle2“).Range(„A“ & i & „:J“ & i)
End If
Next c
Application.CutCopyMode = True
End Sub
______________
Jemand eine Idee was wir noch einfügen müssen, damit der Code wie gewünscht funktioniert?
For Zeile = 1 To MaxZeile + 1
For Spalte = 1 To MaxSpalte
If Sheets(„Tabelle1“).Cells(Zeile, Spalte).Font.ColorIndex = 3 Then
Range(„A“ & Zeile & „:J“ & Zeile).Copy Sheets(„Tabelle2“).Range(„A“ & i & „:J“ & i)
i = i + 1
Exit For
End If
Next
Next
Hallo,
ich würde das glaube ich so machen:
Die Roten Zeilen aus Tabelle 1 in ein Array packen.
Das Array beim befüllen nach Doppelungen prüfen.
Dann das Array in Tabelle 2 schreiben.
Ich wüsste auch nicht, wie ich in der For Each Schleife den Index dazu zu bewegen sich gefälligst in die nächste Zeile zu setzen. Daher würde ich die Zeilen und Spalten jeweils in einer Schleife abarbeiten. Jetzt kann ich auch in die nächste Spalte wechseln. Das sieht bei mir wie folgt aus. Bei mir klappt’s:
Sub FarbigeZeileKopieren()
Dim intRow As Integer
Dim intCol As Integer
Dim intTargetRow As Integer
'Set Bereich = Range(„A3:J1720“)
Worksheets(„Tabelle2“).Range(„A1:J1720“).CurrentRegion.Clear
intTargetRow = 1
For intRow = 1 To 10
For intCol = 1 To 10
If Cells(intRow, intCol).Font.ColorIndex = 3 Then
Range(„A“ & intRow & „:J“ & intRow).Copy Sheets(„Tabelle2“).Range(„A“ & intTargetRow & „:J“ & intTargetRow)
intRow = intRow + 1
intCol = 1
intTargetRow = intTargetRow + 1
End If
Next intCol
Next intRow
hier eine Vorgehensmöglichkeit ohne es ausgetestet zu haben
-Zeilenschalter einbauen
-Wenn neue Zeile, dann Zeilenschalter zurücksetzen
-in Zeile Schalter abfragen
wenn Schalter nicht gesetzt, dann kopieren und
Schalter setzen
Hallo
Danke für deine Hilfe
Der Code hat doppelte zwar gelöscht, aber irgendwie viel zu wenig Einträge angezeugt (bei eigentlich etwa 10 war es einer)
Haben alle Codes jetzt ausgiebig getestet und an Ende genervt festgestellt, dass der pc auf den er laufen sollte, doch nur 2003 ist
So hat der Code aber funktioniert
____
Sub FarbigeZeileKopieren()
Dim Bereich As Range, c As Range, i As Long
Set Bereich = Range(„A1:J1720“)
Worksheets(„Tabelle2“).Range(„A1:J1720“).CurrentRegion.Clear
For Each c In Bereich
If c.Font.ColorIndex = 3 Then
If c.Row Zeile Then
Zeile = c.Row
i = i + 1
Range(„A“ & c.Row & „:J“ & c.Row).Copy Sheets(„Tabelle2“).Range(„A“ & i & „:J“ & i)
End If
End If
Next c
Application.CutCopyMode = True
End Sub
___
Nur in 2003 wollte er cutcopymode nicht mehr und löscht auch die alten einträge nicht mehr (überschreibt nur - geht erstmal auch)
Hallo,
ich würde anstatt if / then mit select case arbeiten.
Dann kann man die selektierte Zeile direkt verlassen.
Also z.B. so:
Sub FarbigeZeileKopieren()
Dim Bereich As Range, c As Range, i As Long
Dim SpaltenArray() As Integer
Dim Farbe as Integer
Set Bereich = Range(„A3:J1720“)
Worksheets(„Tabelle2“).Range(„A1:J1720“).CurrentRegion.Clear
For Each c In Bereich
Farbe = c.Font.ColorIndex
select case Farbe
case is = 3
Range(„A“ & c.Row & „:J“ & c.Row).Copy Sheets(„Tabelle2“).Range(„A“ & i & „:J“ & i)
goto weiter
end select
weiter:
Next c
Application.CutCopyMode = True
End Sub
Habe es nicht getestet, aber könnte klappen.
Gruß Ptonka
P.S. Feedback wäre schön
