Tópicos relacionados a códigos VBA, gravação de macros, etc.
Por Domingsp 26 Fev 2018 às 17:19
Membro 1 Estrela
Mensagens: 63
Reputação: 1
#30572
Olá, boa tarde.Anexei dois arquivos, pasta2 e pasta3.
Essa pastas tem placas de veiculos ficticias. Com a macro TESTEPLACAS eu quero:
1) encontrar placas que constam nos dois arquivos;
2) encontrando, marcar 1, na coluna B da pasta2, na linha correspondente à placa presente nas duas pastas.

Só que a macro não tinha que marcar a WXD-4655 e a EOED-3431 da pasta2 porque elas não correspodem a nenhuma placa da pasta3. Talvez, o problema esteja nos loop. Não tenho prática em trabalhar com arquivos diferentes.
Eu coloquei umas setas nessas placas apenas para mostrar o erro.
Qualquer ajuda é bemvinda.

TESTE.rar
Apenas usuários registrados podem ver ou baixar anexos.
Avatar do usuário
Por gfranco 26 Fev 2018 às 17:27
Membro 5 Estrelas
Mensagens: 2001
Reputação: 1069
#30573
Boa tarde.
Poderia usar apenas um procv dentro se uma função "se" para verificar se a placa consta no outro arquivo e retornar 1 caso o procv não retorne erro e qualquer outro retorno para o caso de não encontrar.
A função procv está entre as que conseguem se atualizar mesmo com o aquivo fechado.
Avatar do usuário
Por gfranco 26 Fev 2018 às 18:39
Membro 5 Estrelas
Mensagens: 2001
Reputação: 1069
#30578
Já que o cenário é esse, eu elencaria como primeira opção o power query.
Transformaria os dois intervalos de dados (das duas pastas) em tabela.
Uma vez os dados no editor de consultas, uma mescla simples me retornaria os dados que estão em ambas as tabelas,
Depois um filtro eliminando as linhas que retornaram nulas e eu teria um consolidado das placas presentes em ambas as pastas de trabalho.
Avatar do usuário
Por alexandrevba 27 Fev 2018 às 16:38
Excel Expert
Mensagens: 1643
Reputação: 578
#30603
Boa tarde!!

Use nossa base de dados, pois há respostar similar a sua dúvida!
Código: Selecionar todosSub AleVBA_6344()
'Este arquivo deve ficar fora do diretório \TESTE\
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim lr As Long
lr = Range("A1").SpecialCells(xlCellTypeLastCell).Row
Dim LastRow As Long
Const strPath As String = "C:\Users\Administrador\Downloads\TESTE\"
    wkbDest.ActiveSheet.Range("A1").CurrentRegion.Clear
    [A1].Value = "Placas": [B1].Value = "Valor"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets("Plan1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("Plan1").Range("A1:A" & LastRow).Copy wkbDest.Sheets("alevba").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Range("B2").Formula = "=COUNTIF($A:$A,A2)"
    Range("B2").AutoFill Destination:=Range("B2:B" & lr)
    With Range("A1:B100")
        .Value = .Value
    End With
    Worksheets("alevba").Range("B1").AutoFilter Field:=2, Criteria1:="1"
    ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
    Application.DisplayAlerts = False
    ActiveSheet.[A1].CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    ActiveSheet.ShowAllData
    'Use o With Statement acima, para evitar repetição
Application.ScreenUpdating = True
End Sub


Att