none
PERCORRER COLUNA DE DADOS E COPIAR DADOS PARA UMA NOVA PLANILHA RRS feed

  • Pergunta

  • Por favor, preciso de ajuda.

    Preciso de um codigo que percorra uma coluna (B) que terão diferentes nomes, porem estes nomes se repetem. Por exemplo:

    Vini
    Vini
    Joao
    Jose
    Jose
    Jose

    Os nomes só se repetem quando agrupados. Não há chance de aparecer um Vini depois de Jose, por exemplo.
    Quando o codigo verificar que o "Vini" parou de repetir, ela copia a range de (B) a (H) e joga pra uma nova workbook com o nome "Vini".

    A ideia é fazer isso até o final das linhas pra todos os nomes que aparecerem.

    Podem me ajudar?

    quarta-feira, 5 de setembro de 2018 12:13

Todas as Respostas

  • Vinivi,

       Achei uma macro que talvez te interesse:

    =================================================
    Excel planilhha vba compara copia nao duplicados ordena e lista não comuns 

    1-) A macro copia a lista na coluna BA, classificar sem duplicados "Ok...., veja "
    2-) Após editar o arquivo (clicando em um botão), cópia da lista na coluna BB, tipo sem duplicados e em ordem crescente.
    2b-) Depois compare a lista de coluna da coluna BA e BB, se um nome de coluna BA não está mais na lista de coluna de Pesquisa com o 
    Col(BB) (Por favor preencha o Lista de  "Dados" dos ítens na coluna Dados ) +  Copy o ÍTEM na folha de  Auxiliar celula(B7)  B7 e imprimir a folha,  então a mensagem  " ítem avaliado enviado para lista de impressão, com certeza o ítem foi separado para impressão  imprido.

    Sub Copiar_dados_em_comum()
      Dim vUltimaLinColC As Long, vUltimaLinOrdem As Long, vUltimaColLin As Integer
      Dim vUltimaLin1 As Long, vUltimaLin2 As Long, vLinha As Long, Rng As Range
      Dim vProcura As String
      
      'o que faremos na planilha principal, usa o with para não ficar repetindo o nome da planilha
      With Sheets("Principal")
      
      [A8].Select
        ' localizar última linha da coluna C
        vUltimaLinColC = .Range("C" & Rows.Count).End(xlUp).Row
        
        ' ultima coluna usada na linha 1
        vUltimaColLin = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
        
        ' Se esta coluna for <= 53 ª a 53 ª seguida
        If vUltimaColLin < 52 Then vUltimaColLin = 53
        
        ' Copiar com filtro avançado
        .Range("C5:C" & vUltimaLinColC).AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=.Cells(1, vUltimaColLin), Unique:=True
        
        ' ultima linha para classificação em ordem
        vUltimaLinOrdem = .Cells(Rows.Count, vUltimaColLin).End(xlUp).Row
       
       'Classificar a coluna Atual
        .Range(.Cells(1, vUltimaColLin), .Cells(vUltimaLinOrdem, vUltimaColLin)).Sort Key1:=.Cells(1, vUltimaColLin), Order1:=xlAscending, Header:=xlGuess, _    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
        ' Se somente a coluna BA estiver cheia, exit sub
          If vUltimaColLin = 53 Then Exit Sub
        
        ' Caso contrário compare as duas colunas
        vUltimaLin1 = .Cells(Rows.Count, vUltimaColLin - 1).End(xlUp).Row
        vUltimaLin2 = .Cells(Rows.Count, vUltimaColLin).End(xlUp).Row
        
        ' Definir O local de busca na segunda coluna
        Set Rng = .Range(.Cells(1, vUltimaColLin), .Cells(vUltimaLin2, vUltimaColLin))
          ' para cada linha na primeira coluna
        For vLinha = 1 To vUltimaLin1
          ' Recuperar o nome da coluna antes da última
          vProcura = .Cells(vLinha, vUltimaColLin - 1).Value
          ' Procurar o nome na coluna ao lado
         '
          If vProcuraLinha(Sheets("Principal"), Rng, vProcura) = 0 Then
             MsgBox "Atenção será preenchida a Lista do ítem ...: [ " & vProcura & " ]", vbInformation, "Saberexcel" '1
             ActiveCell.Value = vProcura
             ActiveCell.Offset(1, 0).Value = vProcura
             ActiveCell.Offset(1, 0).Select
             Sheets("Auxiliar").Range("B7").Value = vProcura
             'Sheets("Auxiliar").PrintOut  'desabilitei senão vai jogar cada volta na fila de impressão...
             'aqui no caso poderá imprimir a lista de não comuns
             MsgBox "Ítem enviado para Lista  de avaliação - ítem...: [ " & vProcura & " ] e também para impressão", vbInformation, "Saberexcel" '2
          End If
        Next vLinha
        
      End With
      Set Rng = Nothing
    End Sub
    
    
    'Função para busca e localização, simples, para fazer uma função voce poderá usar o recurso
    'do proprio aplicativo, o que ensino na lição 1 do nosso curso, como trabalhar com o GM
    
    
    Function vProcuraLinha(Sht As Worksheet, Rng As Range, Localiza As String)
      On Error Resume Next
      vProcuraLinha = 0
      With Sht
        With Rng
          vProcuraLinha = .Find(What:=Localiza, LookIn:=xlValues, LookAt:=xlPart, _
                          SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
                          SearchFormat:=False).Row
        End With
      End With
    End Function

    http://www.microsoftexcel.com.br/index.php/excel-dicas-microsoft-excel-vba/301-excel-vba-compara/781-excel-planilhha-vba-compara-copia-nao-duplicados-ordena-e-lista-nao-comuns.html
    =================================================

       Veja também:

    =================================================
    Macro para copiar e colar em Loop páginas e dados da mesma Planilha

    https://social.msdn.microsoft.com/Forums/pt-BR/b8442cc4-87f7-4965-8923-82594a768486/macro-para-copiar-e-colar-em-loop-pginas-e-dados-da-mesma-planilha
    =================================================
    excel - Procurar valores repetidos em uma coluna e copiá-los na coluna seguinte sem as repetições  
     Por koalabala, Agosto 25, 2010 em Microsoft Office  

    https://forum.baboo.com.br/index.php?/topic/734219-excel-procurar-valores-repetidos-em-uma-coluna-e-copi%C3%A1-los-na-coluna-seguinte-sem-as-repeti%C3%A7%C3%B5es/
    =================================================
    Vídeo aula 18 - Inserindo dados sem repetição e em ordem alfabética em combobox/listbox  
    Renam Ruthes   
    Publicado em 19 de jun de 2013

    https://youtu.be/v0-D7PX_tiU
    =================================================

    []'s,
    Fabio I.

    • Editado Fabio I quarta-feira, 5 de setembro de 2018 13:34
    quarta-feira, 5 de setembro de 2018 13:29