Edson, apesar de ter dito que era exatamente o que queria, fiquei em duvida, pois o modelo do Basole, alias ele já disse que iria ocorrer, se buscarmos pelo código 20 é retornado 6 x ficando com 36 registros duplicados, pelo menos no teste que fiz.
Penso que o pretendido é preencher o código "CRITERIO" em A2" e na busca preencher a Coluna "A" com o código procurado e as demais colunas com os valores correspondentes somente a quantidade existente nos BDs, então com a licença do Basole fiz algumas alterações da forma que entendi, eliminando o Loop referente a Variável "i" e acrescentando a verificação se o criterio estiver em branco e definindo a comparação da Busca pela Variável do Criterio.
Não sei se já chegou a ajustar, mas segue a rotina com as modificações que fiz.
Sub Consulta_DadosdeOutraPastaTrb_comFiltro_RegistrosMauro()
' *** Habilitado a referencia ' Microsoft ActiveX Data Objects X.XX Library' ***
' Rotina que importa dados da Pasta_de_Trabalho "Base.xlsx"
Dim strDB As String
Dim strSQL As String
Dim rst As New ADODB.Recordset
Dim connDB As New ADODB.Connection
' Dim uL As Long
Dim i As Long, uL As Long
Dim contaDados As Integer, contaDados2 As Integer
Dim ws As Worksheet
Dim i_Valor_A2 'Range do Criterio A2
'Armazena o Valor do Criterio em A2
i_Valor_A2 = Range("A2").Value
'Se em branco emite mensagem e sai da rotina
If i_Valor_A2 = "" Then
MsgBox "Criterio em Branco !!", vbExclamation, "Preenchimento Criterio Obrigatório"
Else
On eror GoTo Erro
strDB = ThisWorkbook.Path & "Base.xlsx" ' Altere aqui o local (diretorio), se necessario
connDB.Open ConnectionString:="Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strDB _
& ";Extended Properties=;" & "Excel 12.0 Xml;HDR=YES;IMEX=1;"
strSQL = "SELECT * FROM [material$A4:E]" 'Altere aqui de acordo com o nome da sua planilha(aba), mantendo o($) na ao nome da aba
strSQL = strSQL & " UNION SELECT * FROM [serviço$A4:E]"
rst.Open Source:=strSQL, ActiveConnection:=connDB, CursorType:=adOpenDynamic, LockType:=adLockOptimistic
If Not rst.EOF Then
Set ws = Worksheets("Total")
With ws
uL = .Cells(Rows.Count, "B").End(xlUp).Row
uL = VBA.IIf(uL < 5, 5, uL) ' garante que o vlr minimo sera 5
'.Range("B5:E" & uL).ClearContents ' 'LIMPA os dados do intervalo
'LIMPA os dados do intervalo a partir da Col A
.Range("A5:E" & uL).ClearContents 'LIMPA os dados do intervalo a partir da Col A
'Entendo que iremos preencher a coluna A com o valor do criterio
'então não precisamos contar a Coluna A
'uL = .Cells(Rows.Count, "A").End(xlUp).Row
'Não precisamos do loop referente a Coluna A
'For i = 5 To uL
rst.MoveFirst
Do While rst.EOF = False
uL = .Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
'If .Range("A" & i).Value = rst.Fields(0).Value Then
'Comparamos diretamente o Valor do Criterio
If i_Valor_A2 = rst.Fields(0).Value Then
'Troquei por 0 para preenher as linhas com o criterio tambem
'For j = 1 To rst.Fields.Count - 1
For j = 0 To rst.Fields.Count - 1
.Cells(uL, j + 1) = rst.Fields(j) 'insere os dados importados
Next j
End If
rst.MoveNext
Loop
Set ws = Nothing
'Next i
End With
Set ws = Nothing
rst.Close ' fecha o banco
Set rst = Nothing ' limpa a memoria
connDB.Close ' fecha a conexao
contaDados = Application.WorksheetFunction.CountA(Range("B5:B" & uL)) ' conta a qtd de dados
If contaDados > 0 Then MsgBox contaDados & " Registro(s) retornado(s) para aba [ Total ]" & vbNewLine & _
"Em consulta a: " & strDB, vbDefaultButton1, "Sucesso"
Else
MsgBox "Nenhum registro retornado", 64, " Atencao **"
End If
End If
Exit Sub
Erro:
Set ws = Nothing
rst.Close
Set rst = Nothing
MsgBox Err.Description
End Sub
Se não for isto ou se já ajustou peço desculpas a você e ao Basole por esta intromissão em um tópico que a principio entendi como Resolvido.
[]s
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 21/04/2016 6:16 pm