Clever-Excel-Forum

Seiten: 1 2

Hi,

öffnen den VBA-Editor mit Alt+F11
Öffne den Direktbereich mit Strg+G
scheib da rein:
? selection.interior.color
wenn der Cursor am Ende des Textes ist im Direktfenster drücke Enter
In einer weißen Zelle bekomme ich
16777215
in einer grünen
5287936
in einer roten
255

in excel selbst geh zu einer bunten Zelle und drücke die Tastenkomi Strg+1
Das Fenster 'Zellen formatieren' öffnet sich. in allen Reitern siehste die aktuellen Einstellungen
Anscheinend haben die bunten Zellen nur farbige Hintergründe - Ausfüllen
Ausrichtung / Schrift / Zellformat / Rahmen / Schutz
scheinen Standart zu sein

Lässt sich damit was anfangen?

Wenn du damit ned alleine weiterkommst, schau ich morgen wieder rein. bis dahin

Hallo Wastl,

die Funktion im Direktfenster funktioniert. Leider weiss ich nicht, wie dies in die VBA integriert werden könnte.

Danke Dir und viele Grüße!!!
Lars

Hi Lars,

Dein Code will bei mir nicht, er sucht ein Blatt namens Suche
Da habe ich abgebrochen.
Und einen neuen geschrieben, geht sicherlich eleganter, aber er tut.
Schließlich gehts nur ums Prinzip wie ich den Hintergrund in einer Variable speichere und im neuen Platz wieder ausgebe

Code:
Sub Wastl()

Dim ArrA

ArrA = Cells(1, 1).CurrentRegion

Spalte = UBound(ArrA, 2) '   belegte Spalten Zählen

Zeile = UBound(ArrA, 1) '    belegte Zeilen Zählen

ReDim ArrA(1 To Zeile, 1 To Spalte + 1) '    Arra eine Spalte hinzufügen

For i = 1 To Zeile          ' Arra füllen

    For j = 1 To Spalte

        ArrA(i, j) = Cells(i, j)

    Next j

    ArrA(i, 4) = Cells(i, 1).Interior.Color 'Farbe der Zeile auslesen und in Arra speichern

'    Debug.Print ArrA(i, 4)

Next i

Range("G1").Resize(Zeile, 3) = ArrA ' Arra in Tabelle schreiben

For i = 1 To Zeile

    Range("G" & i & ":I" & i).Interior.Color = ArrA(i, 4) ' Farbe der Zeile hinzufügen

Next i

End Sub

Hallo Wastl,

danke schonmal für die ganzen Mühen.

Die Datei im Anhang ist jetzt auch mit dem richtigen Reiter versehen uns sollte funktionieren.
Aber leider immer noch nicht mit Farbe.

Danke und viele Grüße
Lars

Moin,

nach dem letzten Post von dir liest sich der erste Satz nun ganz anders:

Zitat:seit einigen Jahren benutze ich den angefügten Code, um nach bestimmten Werten in multiplen Arbeitsmappen zu suchen und die Ergebnisse (Zeilen) in einer neuen Arbeitsmappe auszuwerten. Für die bisherige Arbeit war es ein perfektes Tool.

Du willst damit ausdrücken, dass du den Code irgendwo her hast und nicht weist wie man das ändert?
Und du möchtest auch nicht dein Wissen erweitern und deinen Code mit dem von meinem letzten Beitrag vereinen?

Hier nun dein Code erweitert um die Farbe der ersten 3 Spalten, vor mehr Spalten hab ich Angst, weil dein Code ließt ja alle 16384 Spalten aus ohne Rücksicht, ob diese gefüllt sind oder nicht.

Anmerkung:
Vielleicht hättest du erwähnen können/müssen, das dein Code sämtliche Dateien in dem angegebenen Verzeichnis öffnet, durchsucht und danach schließt, auch die Datei mit dem Makro, und auch wenn die Dateien in dem Ordner zu anderen Beiträgen im Clever-Excelforum gehören, wenn sie im selben Ordner liegen.

Code:
Sub SearchWB()

Dim myDir As String, fn As String, ws As Worksheet, r As Range

Dim a(), n As Long, x As Long, myTask As String, ff As String, temp

Dim farbe(), IntI As Integer

myDir = "V:\Test\" '<- change path to folder with files to search

If Dir(myDir, 16) = "" Then

    MsgBox "No such folder path", 64, myDir

    Exit Sub

End If

myTask = InputBox("Suckkriterium:")

If myTask = "" Then Exit Sub

x = Columns.Count

fn = Dir(myDir & "*.*")

    With Application

    .ScreenUpdating = False

    .EnableEvents = False

End With

Do While fn <> ""

    With Workbooks.Open(myDir & fn, 0)

        For Each ws In .Worksheets

            Set r = ws.Cells.Find(myTask, , , 1)

            If Not r Is Nothing Then

                ff = r.Address

                Do

                    n = n + 1

                    temp = r.EntireRow.Value

                    ReDim Preserve temp(1 To 1, 1 To x)

                    ReDim Preserve a(1 To n)

                    ReDim Preserve farbe(1 To n)

                    a(n) = temp

                    farbe(n) = Range(ff).Interior.Color

                    Set r = ws.Cells.FindNext(r)

                Loop While ff <> r.Address

            End If

        Next

        .Close False

    End With

    fn = Dir

Loop

With ThisWorkbook.Sheets("Eintrag SUCHEN").Rows(1)

    .CurrentRegion.Clear

    If n > 0 Then

        .Resize(n).Value = _

        Application.Transpose(Application.Transpose(a))

    Else

        MsgBox "Not found", , myTask

    End If

    For IntI = 1 To n

        Range("A" & IntI & ":C" & IntI).Interior.Color = farbe(IntI)

    Next IntI

End With

End Sub

Seiten: 1 2

Wastl

color code

Wastl

color code

Wastl