Excel VBA 将工作表名称添加到从整行创建的数组中

Question

I have a search function, which loops through Excel workbooks and worksheets and by using Cells.Find returning an array with all rows matching search pattern. The issue is that as files in directory grow I am losing track of which workbook/worksheet the records were found in. I can't figure out how to modify the temp range to inject worksheet/workbook name without breaking entire array. I tried to add worksheet name as array element but transpose do not like that idea.

This is current code:

   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 = Range("P2").Value
Debug.Print Range("P2").Value
If Dir(myDir, 16) = "" Then
    MsgBox "No such folder path", 64, myDir
    Exit Sub
End If
myTask = InputBox("Enter Search String * accepted")
If myTask = "" Then Exit Sub
x = Columns.Count ' <---- Active worksheet count of all columns
fn = Dir(myDir & "*.xls*")
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
Do While fn <> ""
    With Workbooks.Open(myDir & fn, 0)
        For Each ws In .Worksheets ' <- ws is worksheet object ws.Name to return current search worksheet
            Set r = ws.Cells.Find(myTask, , , 1) ' <- Actual find return cells address or Nothing object if not found
            If Not r Is Nothing Then
                ff = r.Address '<- Address of cell where the search was matched
                Do
                    n = n + 1
                    temp = r.EntireRow.Value ' <- take entire row if the cell was found
                    ReDim Preserve temp(1 To 1, 1 To x) ' <- preserve temp data i dynamic array basically one dimensional array of cells, which will become a item in array a
                    ReDim Preserve a(1 To n)
                    a(n) = temp '<- insert temp array as item in array a
                    Set r = ws.Cells.FindNext(r) '<- after finding first mach in the worksheet check if later there is something to matching
                Loop While ff <> r.Address '<- loop through worksheet until we come back to the cell address we initially found
            End If
        Next
        .Close False
    End With
    fn = Dir
Loop
With ThisWorkbook.Sheets("IP_Info").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

Answer 1

With this design you cannot. Your temp array has as much entries as there are columns in Excel (therefore ReDim Preserve temp(1 To 1, 1 To x) is not necessary) so there is no room for additional information that can be written to a row using transpose.

One thing you can do is to use a second array to store the workbook and sheetname. Use n as the index that corresponds to the row in array a and the array containing the workbook and sheet in the other array.

You can also store the row and column in the additional array so you will know the workbook, sheetname, row and column for your match.

if you do not need the complete row but only the value of the cell found you can do the following

::
a(n) = Array(r.Parent.Parent.Name, r.Parent.Name, r.Row, r.Column, r.Value)
:: 

writing to sheet

With ThisWorkbook.Sheets("IP_Info")
    .UsedRange.ClearContents
    if n > 0 then
        .Cells(1, 1).Resize(n, 5).Value = Application.Transpose(Application.Transpose(a))
    end if
end with

Answer 2

Thank you for all the answers, I have solved it by putting search results in new sheet (1 file = one sheet).

Here is the code which works (depends on the file name you can hit and error as it might have illegal characters in file name thus sheet cannot be created)

    Dim myDir As String, fn, fn_temp As String, ws As Worksheet, r As Range
Dim a(), n As Long, x As Long, myTask As String, ff As String, temp
Dim sheet As Worksheet
myDir = Range("P2").Value
Debug.Print Range("P2").Value
If Dir(myDir, 16) = "" Then
    MsgBox "No such folder path", 64, myDir
    Exit Sub
End If
myTask = InputBox("Enter Search String * accepted")
If myTask = "" Then Exit Sub
x = Columns.Count ' <---- Active worksheet count of all columns
fn = Dir(myDir & "*.xls*")
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
Do While fn <> ""
Debug.Print fn

Set sheet = ThisWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
sheet.Name = fn

    With Workbooks.Open(myDir & fn, 0)
        For Each ws In .Worksheets ' <- ws is worksheet object ws.Name to return current search worksheet
            Set r = ws.Cells.Find(myTask, , , 1) ' <- Actual find return cells address or Nothing object if not found
            If Not r Is Nothing Then
                ff = r.Address '<- Address of cell where the search was matched
                Do
                    n = n + 1
                    temp = r.EntireRow.Value ' <- take entire row if the cell was found
                    ReDim Preserve temp(1 To 1, 1 To x) ' <- preserve temp data i dynamic array basically one dimensional array of cells, which will become a item in array a
                    ReDim Preserve a(1 To n)
                    a(n) = temp '<- insert temp array as item in array a
                    Set r = ws.Cells.FindNext(r) '<- after finding first mach in the worksheet check if later there is something to matching
                Loop While ff <> r.Address '<- loop through worksheet until we come back to the cell address we initially found
            End If
        Next
        .Close False
    End With
    fn = Dir
     With ThisWorkbook.Sheets(sheet.Name).Rows(1)
    .CurrentRegion.ClearContents
    If n > 0 Then
        .Resize(n).Value = _
        Application.Transpose(Application.Transpose(a))
        Erase a
        n = 0
    Else
        sheet.Range("A1").Value = "Not found" & myTask & " in " & sheet.Name
        Erase a
        n = 0
    End If
End With
Loop