ich hab eine Arbeitsmappe mit 5 Tabellen, möchte nun in Tabelle 1 einen Button setzten welcher alle Tabellen nach rot Ausgefüllten Zellen durchsucht und diese dann in Tabelle 5 kopiert. Der inhalt der roten zellen in Tabelle 1-4 sollen nach dem kopieren gelöscht werden. Button und so alles keine Problem aber nen code zum suchen in allen Tabellen und dann kopiert klappt irgendwie nicht.
Könnt Ihr mit bitte ein paar tips oder vorschläge geben wie ich das angehen soll?
hier ein sehr rudimentärer Code, den ich auch nicht unbedingt empfehle. Was ist denn das Kriterium, weshalb die Zellen rot werden? Kann man die Suchbereiche eingrenzen?
Code:
Option Explicit
Sub redCells() Dim wks As Worksheet Dim rng As Range Dim redRange As Range
For Each wks In ThisWorkbook.Worksheets If wks.CodeName <> "SheetVonDemDuStartest" Then For Each rng In wks.UsedRange If rng.Interior.Color = vbRed Then SheetVonDemDuStartest.Cells(UsedRange.Rows.Count + 1, 1).Value = rng.Value If redRange Is Nothing Then Set redRange = rng Else Set redRange = Union(redRange, rng) End If End If Next rng redRange.Delete Set redRange = Nothing End If Next wks End Sub
es ist eine Art Lagerverwaltung. Auf allen Tabellenblätter stehen in A5 bis E5 verscheidene Daten, wenn ein Mitarbeiter in Spalte F ein Datum eingibt wird die Zeile von A bis F rot Am Monatsende möchte ich alle roten zeilen in ein extra Tabellenblatt kopieren und diese dann von den anderen Tabellen löschen.
also mein Code oben ist getestet und funktioniert. Wenn Du Interesse an einer Optimierung hast, lade mal bitte eine Beispieldatei mit dem selben Aufbau wie dein Original hoch.
Private Sub CommandButton1_Click() Dim wks As Worksheet Dim i As Long
For Each wks In ThisWorkbook.Worksheets If wks.CodeName <> "Tabelle1" And wks.CodeName <> "Tabelle5" Then For i = 7 To 5 Step -1 With wks If .Cells(i, 4).Value > 0 Then Tabelle5.Cells(Tabelle5.UsedRange.Rows.Count + 1, 1).Resize(1, 4) = .Cells(i, 1).Resize(1, 4).Value .Rows(i).Delete End If End With Next i End If Next wks End Sub
