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

  • Pergunta

  • 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,


    • Editado baleza quinta-feira, 28 de novembro de 2013 00:54 erro de ortografia
    quinta-feira, 28 de novembro de 2013 00:38

Respostas

  • 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

    terça-feira, 3 de dezembro de 2013 23:36
    Moderador

Todas as Respostas

  • Poderia explicar o que deseja fazer?

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

    quinta-feira, 28 de novembro de 2013 22:58
    Moderador
  • 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 !

    sexta-feira, 29 de novembro de 2013 11:06

  • 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

    sexta-feira, 29 de novembro de 2013 22:19
    Moderador

  • 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!

      
    terça-feira, 3 de dezembro de 2013 16:52
  • 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

    terça-feira, 3 de dezembro de 2013 23:36
    Moderador