Excel / VBA Rotfarbige Zeilen 1x kopieren

Computer: Software & Programmierung Visual Basic
#1

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?

(excel 2010)

#2

Tut mir leid, darüber kann ich nichts sagen.
Viel Glück

#3

Hallo DieMila,

leider keine Idee. Sorry.

#4

Hallo DieMila :smile:

Versuch’s mal hiermit.

LG
René

Sub FarbigeZeileKopieren()

Dim Spalte As Integer
Dim Zeile As Integer
Dim MaxSpalte As Integer
Dim MaxZeile As Integer
Dim i As Long

MaxSpalte = 10
MaxZeile = Sheets(„Tabelle1“).Range(„A65535“).End(xlUp).row

i = 1

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

Application.CutCopyMode = True

End Sub

#5

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.

#6

Hallo DieMila :smile:

Versuch’s mal hiermit.

LG
René

Werde ich gleich Montag ausprobieren :smile: Vielen Dank schonmal :smile:

#7

Hallo DieMila,
ich würde die Zeilennummer zwischenspeichern und eine zweite if-Abfrage einfügen. Etwa so:

If c.Font.ColorIndex = 3 Then

If c.Row zeile Then ’

#8

Hallo Mila,
leider kann ich Dir nicht weiterhelfen. VBA ist nicht mein Thema
Gruß Maria

#9

Hallo DieMila,

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

#10

Hallo diemila,

ich habe es probiert, aber leider keine Lösung gefunden.

Gruß Hugo

#11

Hallo DieMila,

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

Gruß
JOGI

#12

Hallo :smile:
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 :frowning:

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)

Danke Für die Hilfe :smile:

#13

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

… mehr auf http://www.wer-weiss-was.de/app/query/display_query?..