Question

我每个月都有工作簿。它们都包含日期，电车号码和延迟原因的行。要指定延迟原因，带有条目的行将用红色或绿色进行颜色编码。要在工作簿中搜索特定的电车轨道号和日期，我使用下面的代码。这是完美的。但结果却出现在没有颜色代码的新表中。我尝试更改application.transpose命令，并与我公司的IT专业人员一起查看ws.cells.find命令。但没人知道VBA。请帮忙。谢谢你的帮助

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

Answer 1

根据用户评论编辑：

这样您只能复制值。试试这个来复制值和格式：

Do
    n = n + 1
    Range(ws.Cells(r.Row, 1), ws.Cells(r.Row, x)).Copy
    Set rDst = ThisWorkbook.Sheets("Eintrag SUCHEN").Cells(1, n)
    rDst.PasteSpecial Transpose:=True
    Set r = ws.Cells.FindNext(r)
Loop ...

这样你就可以消除使用temp和a（）以及Redim Preserve。

从多个工作簿中查找值，并将找到的格式（颜色）行复制到新工作簿中

1 个答案: