hier meine Version
28.04.2010 09:38:00
Tino
Hallo,
die Tabelle und die Farbe musst Du im Code anpassen, ich habe mal rot (Color=255) genommen.
Die Zellen müssen normal gefärbt sein, nicht über Bedingte Formatierung.
Sub FindDaten()
Dim Bereich As Range, rngZelle As Range
Dim strErste$
Dim nCount As Long
Dim MeAr()
'Tabelle anpassen
With Sheets("Terminplan")
'Suchbereich
Set Bereich = .Range("G10:IP500")
'Suchformat löschen
Application.FindFormat.Clear
'hier die Farbe festlegen, hier rot
Application.FindFormat.Interior.Color = 255
''oder für Versionen unter xl2007 mit ColorIndex
'Application.FindFormat.Interior.ColorIndex = 3
Set rngZelle = Bereich.Find(What:="*", After:=Bereich(Bereich.Rows.Count, Bereich.Columns.Count), _
LookIn:=xlValues, SearchDirection:=xlNext, SearchFormat:=True)
If Not rngZelle Is Nothing Then
strErste = rngZelle.Address
nCount = nCount + 2
Redim Preserve MeAr(1 To 3, 1 To nCount)
MeAr(1, nCount - 1) = "Name"
MeAr(2, nCount - 1) = "Datum"
MeAr(3, nCount - 1) = "Daten"
MeAr(1, nCount) = .Cells(rngZelle.Row, 6)
MeAr(2, nCount) = .Cells(9, rngZelle.Column)
MeAr(3, nCount) = rngZelle
Do
'FindNext funktioniert nicht?
Set rngZelle = Bereich.Find(What:="*", After:=rngZelle, _
LookIn:=xlValues, SearchDirection:=xlNext, SearchFormat:=True)
If rngZelle.Address <> strErste Then
nCount = nCount + 1
Redim Preserve MeAr(1 To 3, 1 To nCount)
MeAr(1, nCount) = .Cells(rngZelle.Row, 6)
MeAr(2, nCount) = .Cells(9, rngZelle.Column)
MeAr(3, nCount) = rngZelle
End If
Loop While strErste <> rngZelle.Address
End If
End With
'Suchformat löschen
Application.FindFormat.Clear
'Daten gefunden
If nCount > 0 Then
'neue Tabelle
With Sheets.Add(After:=Sheets(Sheets.Count))
'daten einfügen
.Range("A1").Resize(Ubound(MeAr, 2), Ubound(MeAr)) = Application.Transpose(MeAr)
'Erste ist Überschrift Fett
.Rows(1).Font.Bold = True
End With
End If
End Sub
Gruß Tino