Поиск и извлечение данных из нескольких файлов excel с условием

Question

поэтому у меня есть файл excel (скажем, test.xlsx), и у меня есть несколько файлов excel (xlsm) в одной папке, они имеют одинаковую структуру (5 столбцов, 60 строк, только данные в них разные), я хочу искать каждый файл только по столбцам E и F и если я нахожу конкретное значение (текст), чем копировать весь текст в этой конкретной ячейке в свой файл (test.xlsx), если значение найдено несколько раз в одном файле, чем вставлять значение ячейки в следующую ячейку в той же строке в моем test.xlsx, и перед тем, как перейти к следующему файлу, я хочу, чтобы он вставлял имя файла в данные был найден в той же строке, что и данные, в следующей ячейке ... чем когда поиск переходит к следующему файлу, я хочу, чтобы данные были извлечены из того, который должен быть вставлен в новую строку, и так далее. Я должен делать это каждый месяц, и я делаю это вручную, не могли бы вы мне помочь? Спасибо.

Answer 1

Прежде всего - ваш Test.xlsx должен быть XLSM, если ваш код там. Все остальные файлы (только с данными), если у них нет кода, должны быть xlsx.

Теперь - попробуйте этот код с вышеуказанными изменениями в модуле в Test.xlsm:

Sub openFilesExtractData() 

    Dim folderPath As String, path As String, yourText As String 
    Dim currWbSh As Worksheet 
    Dim i As Long, j As Long, k As Long 

    folderPath = ThisWorkbook.path 

    path = folderPath & "\*.xlsx" 

    Filename = Dir(path) 

    j = ThisWorkbook.Worksheets(1).UsedRange.Rows.count + 1 
    k = 1 

    Do While Filename <> "" 

     If Filename <> ThisWorkbook.Name And Filename <> "" Then 

      Workbooks.Open folderPath & "\" & Filename 

      Set currWbSh = Workbooks(Filename).Worksheets(1) 

      yourText = InputBox("What are you searching for?") 

      For i = 1 To currWbSh.UsedRange.Rows.count 

       Select Case yourText 

        Case currWbSh.Cells(i, 5): 

         ThisWorkbook.Worksheets(1).Cells(j, k) = yourText 
         k = k + 1 

        Case currWbSh.Cells(i, 6): 

         ThisWorkbook.Worksheets(1).Cells(j, k) = yourText 
         k = k + 1 

       End Select 

       If i = currWbSh.UsedRange.Rows.count And k <> 1 Then 

        ThisWorkbook.Worksheets(1).Cells(j, k) = Filename 
        j = j + 1 

       End If 

      Next i 

      Workbooks(Filename).Close False 

     End If 

     Filename = Dir() 
     k = 1 
     j = ThisWorkbook.Worksheets(1).UsedRange.Rows.count + 1 

    Loop 

End Sub 

Это откроет каждый файл по указанному пути с файл, заканчивающийся XLSX, поиск для вашего inputtext yourText и добавляем искомый текст в формате A1. Если одно и то же значение будет найдено снова, оно будет записано в следующем столбце (в той же строке) и так далее; после этого имя открытого файла помещается в следующий столбец той же строки.