Como pesquisar uma string em várias pastas de trabalho e copiar a linha se for verdadeira

Question

Eu preciso gerar um relatório para um cliente.

Eu tenho aproximadamente 50 arquivos (pastas de trabalho do Excel 2007) em uma pasta. Cada pasta de trabalho tem cerca de cem linhas e dez colunas. Eu preciso procurar uma string (em uma coluna conhecida 'c1: c100') "nome do cliente". Se esta pesquisa for positiva, copie toda a linha (1:10 colunas) para a nova folha de relatório.

Eu tentei gravar uma macro, mas fiquei confuso com a codificação e como fazer tudo variar.

    

Answer 1

Cole esse código no VBA Explorer e altere o caminho na linha 4 para apontar para a pasta que contém os arquivos (certifique-se de incluir a barra à direita).

Isso pesquisará todas as linhas e colunas. Se houver outras instâncias da cadeia de pesquisa em colunas diferentes de C, elas também serão retornadas. Ele pode ser modificado para pesquisar apenas um único intervalo de coluna, mas não funcionaria mais se o intervalo fosse alterado por algum motivo.

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 = "C:\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("Enter Customer Name")
    If myTask = "" Then Exit Sub
    x = Columns.Count
    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
                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(1).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

Observação: isso foi testado no Excel 2010, mas deve ser executado corretamente em 2007. Código modificado desta fonte .