Este fórum está sendo desativado

[FRF]

Pessoal, boa tarde.

Alguem pode me ajudar com uma duvida?

Alguem sabe como eu posso fazer para fazer para buscar com o ADO, um valor especifico em todas as planilhas de uma unica pasta, e quando encontrar, a macro abre o arquivo e seleciona a célula com o valor.

Pois sem ADO a macro vai ficar muito lenta.

[Basole]

Segue exemplo, considerando-se que os arquivos que serão procurados tenham formatação, intervalos de dados e nome da aba em comum.

Código: Selecionar todos

    Dim path As String
    Dim script As Object
    Dim catalogue As Object
    Dim query As String
    Dim cnStr As String
    Dim rs As Object
    Dim wbFile As Variant
    Dim fldr As FileDialog
    Dim sItem As String
    Dim fld As Variant
    Dim wb As Workbook
    Dim i As Integer
    Dim J As Integer
    Dim ValorProcurado As Single
    
    ValorProcurado = 10
    
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    
    With fldr
        .Title = "Selecione a Pasta"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.path
        If .Show <> -1 Then Exit Sub
        sItem = .SelectedItems(1)
    End With
    
    Set fldr = Nothing
    
    path = sItem
    
    Set script = CreateObject("Scripting.FileSystemObject")
    
    Set catalogue = script.GetFolder(path)
    
    Application.ScreenUpdating = False
    Application.AskToUpdateLinks = False
    
    query = "SELECT * FROM [Plan1$A2:G20]"
    
    
    For Each wbFile In catalogue.Files
    
        If Dir(wbFile, vbArchive) Like "*.xls*" Then
            
            cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & wbFile & ";" & _
            "Extended Properties=Excel 12.0"
            
            Set rs = CreateObject("ADODB.Recordset")
            rs.Open query, cnStr, 1, 3
            
            If Not rs.bof Then
                rs.movefirst
                
                
                
                Do While rs.bof = False
                i = i + 1
                    For J = 0 To rs.Fields.Count - 1
                        
                        If rs.Fields(J).Value = ValorProcurado Then
                            ' ABRE O ARQ VALOR LOCALIZADO
                            Set wb = Application.Workbooks.Open(wbFile)
                            wb.Sheets("plan1").Activate
                            wb.Sheets("plan1").Cells(i - 1, J).Select
                            Exit Sub
                        End If
                        
                    Next J
                    rs.movenext
                Loop
                
                rs.Close
                Set rs = Nothing
            End If
        End If
    Next wbFile
    
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True
    
    wb.Close False
    Set wb = Nothing
    

Altere no código o valor procurado, nome da aba e intervalo de dados

[FRF]

Basole, boa noite.

Muito obrigado pela resposta...

mas esta aparecendo o seguinte erro.


Tentei entender e depurar varias vezes mas não entendi como localizar o erro.

[FRF]

Outra duvida também.

Não daria para ir buscando direto pelo FSO sem usar o FileDialog(msoFileDialogFolderPicker)?

[FRF]

'''Consegui fazer a conexão, fazer a busca e parar na célula encontrada da seguinte forma:

Código: Selecionar todos

Sub teste_21_ADO()

Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim sql As String, arq As String, pasta As Object, c As Object

ValorProcurado = 222


Set fso = CreateObject("Scripting.FileSystemObject")
Set pasta = fso.GetFolder(ThisWorkbook.path & "\teste_bases")
Set arquivos = pasta.Files

Application.DisplayAlerts = False
Application.ScreenUpdating = False


For Each c In arquivos
   
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
    
With cn
    .Provider = "Microsoft.ACE.Oledb.12.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.path & _
        "\teste_bases\" & c.Name & ";" & "Extended Properties=Excel 12.0"
     .Open
End With
With rs
    .ActiveConnection = cn
    .CursorType = adOpenKeyset
    .LockType = adLockBatchOptimistic
    sql = "select * from [Planilha1$C1:C4390]"
    .Open sql
End With
    


Do While Not rs.EOF

                    For J = 0 To rs.Fields.Count - 1
                       
                        If rs.Fields(J).Value = ValorProcurado Then
                            ' ABRE O ARQ VALOR LOCALIZADO
                            Application.Workbooks.Open ThisWorkbook.path & _
        "\teste_bases\" & c.Name
                            Sheets("Planilha1").Activate
                            Cells.Find(ValorProcurado).Activate
                            Exit Sub
                        End If
                       
                    Next J

            rs.MoveNext
Loop
    
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
    


Next c




End Sub

' Porém simulando este exemplo em várias base com várias linhas, a macro "até pode ser rápida". Mas ainda demora muito.

'Seria possível ao invés de usar os métodos DO WHILE e FOR para ficar percorrendo célula por célula, usar um método FIND que procuraria o valor extado diretamente do RECORDSET, e se a busca falhar ele passa para o proximo arquivo.

'Se for possivel fazer isso seria muito interessante, pois o ADO em uma situação com varias bases de dados ficaria bem mais rapido.

[FRF]

Desculpem....

Faltou o ponto de interrogação na ultima mensagem....rsrs

'Seria possível ao invés de usar os métodos DO WHILE e FOR para ficar percorrendo célula por célula, usar um método FIND que procuraria o valor extado diretamente do RECORDSET, e se a busca falhar ele passa para o proximo arquivo?

[Basole]

Não sei se esta se referindo a função find do excel, se sim o find não funciona no objeto recordset, só poderia usar com a pasta de trabalho aberta.

No ado tem o recordset.Find, mas tem que especificar o campo ou coluna (para entender melhor), que deseja procurar.

Exemplo: http://www.java2s.com/Code/VBA-Excel-Ac ... Method.htm

Mas se tiver uma coluna especifica onde o dado se encontra pode usar a instrução sql, select * from [tabela] where [campo] = 222

[FRF]

Basole, boa noite.

Muito obrigado pelo retorno.

Sua resposta foi fundamental para conseguir executar a macro...


Porém surgiu uma outra duvida que infelizmente não encontrei a resposta até agora.

Com a macro a seguir eu consigo fazer o seguinte.

Acessar a base de dados do excel, trazer os registros, deletar a planilha e passar para a próxima.

Veja a seguir.

Código: Selecionar todos

Sub TESTE()




Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim sql As String, pasta As Object, c As Object, fso As Object, arquivos As Object
Dim proxima As Long



Set fso = CreateObject("Scripting.FileSystemObject")
Set pasta = fso.GetFolder(ThisWorkbook.Path & "\REPORTE")
Set arquivos = pasta.Files

Application.DisplayAlerts = False
Application.ScreenUpdating = False




For Each c In arquivos
   
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset

    
With cn
     .Provider = "Microsoft.ACE.Oledb.12.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.Path & _
        "\REPORTE\" & c.Name & ";" & "Extended Properties=Excel 12.0"
     .Open
End With
With rs
    .ActiveConnection = cn
    .CursorType = adOpenKeyset
    .LockType = adLockBatchOptimistic
    sql = "select * from [Planilha1$]"
    .Open sql
End With


    
proxima = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row


ThisWorkbook.Sheets("A PAGAR").Range(Cells(proxima, 1), Cells(proxima, 1)).CopyFromRecordset rs
    
    
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing

Kill ThisWorkbook.Path & "\REPORTE\" & c.Name



Next c
   


End Sub

Porém no final do quebra-cabeça ainda falta 1 peça, o banco de dados excel é criptografado com senha(cuja senha eu defini e sei).
Ai eu volto a estaca zero...rsrsrs

Eu já sei conectar a um access com senha, mas excel não.

Já tentou uma rotina como essa antes?

[Basole]

Sim. E entendi que todas as Planilhas (pasta_de_trabalho) estão protegidas com senha e a senha é comum para todas.

Se for isso, veja o exemplo.

Código: Selecionar todos

Sub TESTE()
    Dim cn As ADODB.Connection, rs As ADODB.Recordset
    Dim sql As String, pasta As Object, c As Object, fso As Object, arquivos As Object
    Dim proxima As Long, xlObj As Object, xlWb As Object, SuaSnh As String
    
    
    SuaSnh = "123" ' *** ALTERE A SUA SENHA ***
    
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set pasta = fso.GetFolder(ThisWorkbook.Path & "\REPORTE")
    
    Set arquivos = pasta.Files
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ' cria o objeto excel
    On Error Resume Next
    Set xlObj = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo Trata_Erro
        Set xlObj = CreateObject("excel.application")
    Else
        On Error GoTo Trata_Erro
    End If
    
    
    For Each c In arquivos
        
        Set xlWb = xlObj.Workbooks.Open(pasta & "\" & c.Name, False, False, , SuaSnh)
        
        Set cn = New ADODB.Connection
        Set rs = New ADODB.Recordset
        
        
        With cn
            .Provider = "Microsoft.ACE.Oledb.12.0"
            .ConnectionString = "Data Source=" & pasta & _
            "\" & c.Name & ";" & "Extended Properties=Excel 12.0"
            .Open
        End With
        With rs
            .ActiveConnection = cn
            .CursorType = adOpenKeyset
            .LockType = adLockBatchOptimistic
            sql = "select * from [Planilha1$]"
            .Open sql
        End With
        
        With ThisWorkbook.Sheets("A PAGAR")
            
            proxima = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            
            .Range(.Cells(proxima, 1), .Cells(proxima, 1)).CopyFromRecordset rs
            
        End With
        
        rs.Close
        cn.Close
        Set rs = Nothing
        Set cn = Nothing
        Set xlWb = Nothing
        
        Kill pasta & "\" & c.Name
        
    Next c
    
    If Err.Number <> 0 Then
Trata_Erro:         MsgBox Err.Number & " " & Err.Description, vbCritical
        Err.Clear
        On Error GoTo 0
    End If
    
    Set xlObj = Nothing
    Set xlWb = Nothing
    
End Sub

* Ah é importante frisar que as pastas de trabalho que serão pesquisadas, não podem ter senha de gravação.

.

[FRF]

Basole,

Mas dessa forma o código não tentará abrir cada pasta?

Não queria abrir pasta a pasta pelo metodo worbooks.open

E sim, somente acessar o arquivo com senha via ADO sem precisar abrir pasta a pasta.

Você acha isso possivel?

[FRF]

Basole, boa noite.

A respeito do código que você postou acima...eu acabei de testar.

É uma forma de fazer.

Porém ele abre pasta por pasta. Com isso inviabiliza a tecnologia ADO para extrair dados sem abrir o arquivo.

Se tiver como fazer seria muiiiiiito bom! : )
rsrsrs.

[Basole]

Não queria abrir pasta a pasta pelo metodo worbooks.open
E sim, somente acessar o arquivo com senha via ADO sem precisar abrir pasta a pasta.
Você acha isso possivel?

Não é possivel se os arquivos estão com senha, para desprotege-los, só abrindo mesmo para inserir a senha.

[FRF]

Basole, muito obrigado pela orientação.

Pelo que vejo acho que vou acabar migrando a solução desse assunto em especifico para arquivos em access, não que eu queira dizer que os aplicativos do office sejam perfeitamente seguros, porém creio que seja melhor.

Se voce tiver mais alguma ideia...aguardarei sua resposta...

[Basole]

Uma sugestão seria 'guardar' esses dados um um banco Access, como citou, com varias tabelas e protegido por senha, ou vários bancos se preferir.
E fazendo alguns ajustes no seu código, acredito que atenderá de forma satisfatória.

[FRF]

Basole, boa noite.

É exatamente o que irei fazer. Com isso, acredito também, que a macro será mais veloz.

Vou considerar como resolvido...

Muito obrigado pelo feedback!

Até a próxima.