Suchfunktion soll alle Werte finden

Sub Suche_Fehlt() Set suchsheet = ActiveSheet strFind = "Fehlt" Set rng = ActiveSheet.Cells.Find(strFind, Lookat:=xlWhole, LookIn:=xlFormulas) If Not rng Is Nothing Then strAddress = rng.Address Do Application.Goto rng, False ActiveCell.Offset(0, -5).Select Selection.Copy Sheets("Auswertung").Select ErsteFreieZelle = Range("A36").End(xlDown).Row + 1 Range("A" & ErsteFreieZelle).Select ActiveSheet.Paste suchsheet.Select If rng.Address = strAddress Then Exit Do Loop End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
kannst mal so versuchen.

Sub Suche_Fehlt()
Dim rng As Range, tmprng As Range
Dim strErste As String, strFind As String
Dim suchsheet As Worksheet
Dim lngRow As Long

Set suchsheet = ActiveSheet
strFind = "Fehlt"

Set tmprng = suchsheet.Cells.Find(strFind, Lookat:=xlWhole, LookIn:=xlValues, SearchDirection:=xlNext)
If Not tmprng Is Nothing Then 'was gefunden? 
    strErste = tmprng.Address 'Zelle merken 
    Do
       If tmprng.Column > 5 Then 'nur Spalte größer 5 
        If Not rng Is Nothing Then
            Set rng = Union(rng, tmprng.Offset(0, -5))
        Else
            Set rng = tmprng.Offset(0, -5)
        End If
       End If
       Set tmprng = suchsheet.Cells.FindNext(tmprng) 'nächste suchen 
    Loop While strErste <> tmprng.Address 'wieder bei der ersten, Schleife verlassen 
End If

If Not rng Is Nothing Then
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
            With Sheets("Auswertung") 'kopieren nach Tabelle 
                lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte belegte Zelle in A 
                For Each rng In rng 'Schleife über alle gefundenen Zellen 
                    lngRow = lngRow + 1
                    rng.Copy .Cells(lngRow, 1) 'kopieren 
                Next
            End With
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End If

End Sub

Gruß Tino

With Sheets("Auswertung") 'kopieren nach Tabelle For Each rng In rng 'Schleife über alle gefundenen Zellen lngRow = .Range("A36").End(xlDown).Row + 1 rng.Copy .Cells(lngRow, 1) 'kopieren Next End With

Hallo Tino,
ich hab sowieso ein Farbsehvermögen, da kann ich bei Farben sowieso nicht mitreden.
Aber per Zufall lag mal irgendwo vor Jahren ein dickes Buch mit Bildern rum. Irgendwas für Drucker, Künstler, Maler, was weiß ich.
Ich hab da mal so geblättert. Da waren viele Bilder von "Schwarz", die waren alle schon Schwarz aber sogar ich konnte erkennen, es waren Unterschiede im "Schwarz".
Jetzt nicht nur matt oder glänzende.
Viele davon hätte ich als tiefschwarz bezeichnet, aber ich sah die sind aus mir unerklärlichen Gründen doch unterschiedlich.
Also beschreib mal bitte "helles Schwarz" exakt *lächel*
Ich glaube, so Drucker o.ä. haben sowieso kein rgb Farben, eher das andere farbsysteme wo ich den namen grad nicht weiß, jedenfalls gab es schon Anfragen in einem Excelbrett, wie jmd. deer nur rgb-Bilder hat, diese umwandeln kann in das andere farbsystem damit seine Druckerei was damit anfangen kann.
Mir völlig unklar warum da eine Druckerei nicht entsprechende Software hat.
Gruß
Reinhard

Beliebteste Forumthreads (12 Monate)

Suchfunktion soll alle Werte finden

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Suchfunktion soll alle Werte finden

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread