複数のExcelファイルからデータを検索して抽出するには、条件が

Question

となるようにExcelファイルを作成してください（test.xlsxとしましょう）、複数のExcelファイル（xlsm）を1つのフォルダに持っています。私は特定の値（テキスト）を見つける場合は、その特定のセル内のすべてのテキストを自分のファイルにコピーするよりも（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を終わるファイルで指定したパス内のすべてのファイルを開きます。入力テキストyourTextを入力し、検索したテキストをA1に追加します。同じ値が再び見つかると、次の列（同じ行）に書き込みます。その後に開いたファイルの名前は同じ行の次の列に置かれます。