18.02.2018, 20:35
Hallo zusammen,
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.
Jetzt wollte ich es aber auch bei farbkodierten Zeilen in Arbeitsmappen ausprobieren. Leider wird beim Transposevorgang der Farbwert nicht mitgenommen. Ich habe den Code auf verschiedenste Weise versucht umzuschreiben. Ohne Erfolg.
Vielleicht sieht jemand die Lösung.
Danke für Eure Mühen.
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.
Jetzt wollte ich es aber auch bei farbkodierten Zeilen in Arbeitsmappen ausprobieren. Leider wird beim Transposevorgang der Farbwert nicht mitgenommen. Ich habe den Code auf verschiedenste Weise versucht umzuschreiben. Ohne Erfolg.
Vielleicht sieht jemand die Lösung.
Danke für Eure Mühen.
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
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)
a(n) = temp
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.ClearContents
If n > 0 Then
.Resize(n).Value = _
Application.Transpose(Application.Transpose(a))
Else
MsgBox "Not found", , myTask
End If
End With
End Sub
