Wert in multiplen Arbeitsmappen finden und Zeilen in neue Arbeitsmappe kopieren

[Wastl]

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

[color code]

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

[Wastl]

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

[color code]

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

[Wastl]

Moin,

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

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