Código VBA colocar os valores em sua determinada VANTAGEM por coluna usando critério DATA X NOME .

Question

Boa noite a todos!

Tenho uma planilha de VANTAGEM dos funcionário gostaria de colocar os valores das vantagens que estão em BD nas respectivas colunas de RESUMO , participo de outros fóruns e um abençõado tentou me ajudar mais não conseguiu pq o conhecimento dele em VBA  é limitado principalmente em funções avançadas dessa ferramenta.

Veja o CÓDIGO no MODULO da planilha, a forma com que ele fez funciona perfeito mais com poucos dados, como eu tenho mais de 50.000 linhas ele fica rodando mais de uma hora de relógio para poder executar a tarefa.

Alguém pode me ajudar ? Ou até mesmo implementar esse código para que funcione em uma planilha com 50.000 linhas ou mais ?

Segue o link para download :

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

Um grande abraço a todos e conto com vocês,

Answer 1

Poderia explicar o que deseja fazer?

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 2

Costa meu xará ,rsrs

Você chegou a baixar a planilha no link que disponibilizei , lá tem uma explicação . 

Coloque a MACRO para rodar que já existe lá que você irá entender melhor !

A MACRO que existe lá funciona mais para poucos dados, quando é para dados maiores tipo 50 mil linhas ele leva mais de três horas para realizar o processo.

Obrigado !

Answer 3

Mais uma pergunta: qual foi o critéro adotado para eliminar as duplicatas DataRef+Nome? Conservar o primeiro par da lista e eliminar os pares iguais?

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 4

Mais uma pergunta: qual foi o critéro adotado para eliminar as duplicatas DataRef+Nome? Conservar o primeiro par da lista e eliminar os pares iguais?

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

   Olá Benzadeus,

 Boa tarde!

Isso mesmo meu amigo, gostaria que só ficasse um dos pares iguais .

Obrigado!

  

Answer 5

Sub fnc()
  Dim wksBD As Worksheet
  Dim wksResumo As Worksheet
  Dim lngCol As Long
  Dim lngResumo As Long
  Dim lngBD As Long
  
  With ThisWorkbook
    Set wksBD = .Worksheets("BD")
    wksBD.Copy After:=.Sheets(.Sheets.Count)
    Set wksResumo = ActiveSheet
  End With
  
  wksResumo.Cells.RemoveDuplicates Columns:=Array(1, 4), Header:=xlYes
  
  lngResumo = 2
  lngBD = 2
  Do
    GoSub subPreencher
    Do While wksBD.Cells(lngBD, "A").Value = wksBD.Cells(lngBD - 1, "A").Value _
             And wksBD.Cells(lngBD, "D").Value = wksBD.Cells(lngBD - 1, "D").Value
      GoSub subPreencher
    Loop
    lngBD = lngBD + 1
    lngResumo = lngResumo + 1
    DoEvents
  Loop While wksBD.Cells(lngBD + 1, "A").Value <> ""

Exit Sub

subPreencher:
  lngCol = fncGetCol(wksBD.Cells(lngBD, "U").Value, wksResumo.range("W1:EM1"))
  wksResumo.Cells(lngResumo, lngCol).Value = wksBD.Cells(lngBD, "V").Value
  lngBD = lngBD + 1
Return
End Sub

Function fncGetCol(ByVal str As String, ByVal rng As range) As Long
  Dim Temp As Long
  
  On Error Resume Next
  Temp = WorksheetFunction.Match(str + 0, rng, 0)
  If Temp = 0 Then Temp = WorksheetFunction.Match(CStr(str), rng, 0)
  If Temp > 0 Then
    Temp = Temp + rng.Column - 1
  End If
  
  fncGetCol = Temp
End Function

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br