AW: Suchen und Kopieren
13.05.2006 12:47:07
Franz
Hallo Ralf,
hier zwei Makrolösungen für deine Fragen:
Sub X_Archivieren()
Dim Suchbereich As Range, Daten As Range, Finden As Range
Dim wks1 As Worksheet, Archiv As Worksheet, Adresse As String
Set wks1 = ActiveWorkbook.Sheets("Daten")
Set Archiv = ActiveWorkbook.Sheets("Archiv")
Set Suchbereich = wks1.Range("K2:K" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
With Suchbereich
Set Finden = .Find(What:="X", LookIn:=xlValue, Lookat:=xlWhole, MatchCase:=False)
If Finden Is Nothing Then Exit Sub
Adresse = Finden.Address
Do
Set Daten = wks1.Range(wks1.Cells(Finden.Row, "A"), wks1.Cells(Finden.Row, "L"))
Daten.Interior.ColorIndex = 3 ' Farbe = rot
Daten.Copy
Zeile = Archiv.UsedRange.Row + Archiv.UsedRange.Rows.Count
Archiv.Cells(Zeile, "A").PasteSpecial Paste:=xlValues
Archiv.Cells(Zeile, "M").Value = Date
Set Finden = .FindNext(Finden)
Loop While Not Finden Is Nothing And Adresse <> Finden.Address
End With
Application.CutCopyMode = False
End Sub
Sub RoteZaehlen()
Dim wks1 As Worksheet, Zelle As Range, Zaehler As Long
Set wks1 = ActiveWorkbook.Sheets("Daten")
For Each Zelle In wks1.Range("K2:K" & wks1.UsedRange.Row + wks1.UsedRange.Rows.Count - 1)
If Zelle.Interior.ColorIndex = 3 Then Zaehler = Zaehler + 1
Next Zelle
MsgBox ("Es sind" & Zaehler & " Zeilen rot gefärbt.")
End Sub
Gruß
Franz