Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Procv com crtiério ...
 
Notifications
Clear all

Procv com crtiério - VB

 
2024 - VBA & Macros
5 Posts
2 Usuários
0 Reactions
934 Visualizações
RSS
 xmiguelx
(@xmiguelx)
Posts: 34
Eminent Member
Topic starter
 

Olá pessoal,

Por favor, se alguém poder dar um Help:

Tenho uma planilha com uma aba Tabela de Preços ( Coluna A - Código / Coluna B - Preço / Coluna C - Data Inicial / Coluna D - Data Final )

Em outra aba Entrada ( Coluna A - Código / Coluna B - Preço / Coluna C - Data de Emissão )

Gostaria que na coluna B da tabela de entrada busque o preço na Tabela de Preços porém dentro do intervalo da data Inicial e data final conforme data de emissão da nota.
* Na tabela de Preço, pode ter mais de uma vez o mesmo código com intervalo de data inicial e final diferente.
* Na tabela de Entrada teremos o código repetido, tendo a data de emissão igual ou diferente.
Caso não tenha informação dentro deste intervalo para este código, apresente a mensagem na célula ( Sem preço ).

Tenho o código abaixo, porém se na tabela Entrada, tem o mesmo código com período diferente ele não encontra.
Ele encontra somente o primeiro periodo na tabela de preços.

Segue abaixo, mas se quiserem alterar tudo, sem problemas.

Dim lin As Long, i As Long, data_f As Date, data_i As Date
Sub procv()
    ThisWorkbook.Activate
    Sheets("Entrada").Select
    Range("A64000").Select
    Selection.End(xlUp).Select
    lin = ActiveCell.Row
    For i = 2 To lin
        data_f = Application.WorksheetFunction.VLookup(Range("A" & i), Sheets("Tabela de Preços").Range("A:D"), 4, 0)
        data_i = Application.WorksheetFunction.VLookup(Range("A" & i), Sheets("Tabela de Preços").Range("A:D"), 3, 0)
        If Cells(i, 3).Value >= data_i And Cells(i, 3).Value <= data_f Then
            Cells(i, 2).Value = Application.WorksheetFunction.VLookup(Range("A" & i), Sheets("Tabela de Preços").Range("A:D"), 2, 0)
        Else
            Cells(i, 2).Value = "Sem Preço"
        End If
    Next i



End Sub
 
Postado : 09/04/2014 11:09 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa tarde!!

Se for possível, enquanto as feras de VBA não lhe responda, há a possibilidade de postar seu arquivo compactado modelo ?

Att

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 09/04/2014 11:43 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Sem poder testar com a estrutura de seu arquivo, veja se a rotina lhe auxilia, caso não consiga aplicar/modificar a sua necessidade, poste um modelo de seu arquivo

Sub Atualiza()
'Declaraçao das Variaveis
Dim Procurar As String
Dim EndPrimeiroItem As Variant, Localizado As Variant
Dim i As Long, Lin As Long
For i = 2 To Lin
Procurar = Sheets("Entrada").Cells(i, 1)
If Procurar = "" Then Exit Sub

Sheets("Tabela de Preços").Range("A:A").Select

Application.ScreenUpdating = False

With Sheets("Tabela de Preços").Range("A:A")
      
' Carrega a variavel de Objeto Localizado--Para localizar parte de um texto na celula, mudar a propriedade para xlPart
Set Localizado = .Find(Procurar, LookIn:=xlValues, LookAt:=xlWhole)
    
If Not Localizado Is Nothing Then
    EndPrimeiroItem = Localizado.Address 'guarda o endereço da célula do 1º.valor localizado
    Do
    If Sheets("Entrada").Cells(i, 3) > Sheets("Tabela de Preços").Cells(Localizado.Row, 3) And _
       Sheets("Entrada").Cells(i, 3) < Sheets("Tabela de Preços").Cells(Localizado.Row, 4) Then
       Sheets("Entrada").Cells(i, 2) = Sheets("Tabela de Preços").Cells(Localizado.Row, 2)
    Else
        Set Localizado = .FindNext(Localizado)  'Segue a procura
        Loop While Not Localizado Is Nothing And Localizado.Address <> EndPrimeiroItem
    End If
End If
If Sheets("Entrada").Cells(i, 2) = "" Then Sheets("Entrada").Cells(i, 2) = "Sem"
End With
Next
End Sub

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 09/04/2014 12:14 pm
 xmiguelx
(@xmiguelx)
Posts: 34
Eminent Member
Topic starter
 

Olá Amigo,

Apareceu um erro.

Segue teste abaixo:

http://www.sendspace.com/file/be7gkc

Vlw

 
Postado : 09/04/2014 12:48 pm
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Substitua/altere por esta

Sub Atualiza()
'Declaraçao das Variaveis
Dim Procurar As String
Dim EndPrimeiroItem As Variant, Localizado As Variant
Dim i As Long, Lin As Long
Lin = Sheets("Entrada").Cells(Cells.Rows.Count, "A").End(xlUp).Row

For i = 2 To Lin
Procurar = Sheets("Entrada").Cells(i, 1)
'MsgBox Procurar
If Procurar = "" Then Exit Sub

'Sheets("Tabela de Preços").Range("A:A").Select

Application.ScreenUpdating = False

With Sheets("Tabela de Preços").Range("A:A")
      
' Carrega a variavel de Objeto Localizado--Para localizar parte de um texto na celula, mudar a propriedade para xlPart
Set Localizado = .Find(Procurar, LookIn:=xlValues, LookAt:=xlWhole)
    
If Not Localizado Is Nothing Then
    EndPrimeiroItem = Localizado.Address 'guarda o endereço da célula do 1º.valor localizado
    Do
    If Sheets("Entrada").Cells(i, 3) >= Sheets("Tabela de Preços").Cells(Localizado.Row, 3) And _
       Sheets("Entrada").Cells(i, 3) <= Sheets("Tabela de Preços").Cells(Localizado.Row, 4) Then
       Sheets("Entrada").Cells(i, 2) = Sheets("Tabela de Preços").Cells(Localizado.Row, 2)
    Else
    End If
    Set Localizado = .FindNext(Localizado)  'Segue a procura
    Loop While Not Localizado Is Nothing And Localizado.Address <> EndPrimeiroItem
End If
If Sheets("Entrada").Cells(i, 2) = "" Then Sheets("Entrada").Cells(i, 2) = "Sem Preço"
End With
Next
End Sub

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 10/04/2014 6:42 am
Forum Jump:
  Tópico Anterior
Próximo Tópico