none
Copiar linha inteira segundo um Critério RRS feed

  • Pergunta

  • Bom dia a todos!

    Estava pesquisando sobre o assunto mas não encontrei algo que possa me ajudar.

    Preciso que toda a linha da plan 1 seja copiada caso o número que conste na plan 2 coluna A seja igual a da coluna A da plan 1.

    Exemplo:

    Plan 1

        A          B                  C                   D

    10001    11:10    20-outubro-2014    Tentar Novamente

    10001    11:15    21-outubro-2014    Aberto

    10002    11:17    23-outubro-2014    Tentar Novamente 

    10003    11:30    25-outubro-2014    Aberto

    10003    11:35    26-outubro-2014    Informado

    10004    11:15    27-outubro-2014    Fechado

    Plan2 

       A           B              C                             D                          E                  F                       G

    10001    11:10    20-outubro-2014    Tentar Novamente    11:15    21-outubro-2014      Aberto

    10002    11:17    23-outubro-2014    Tentar Novamente 

    10003    11:30    25-outubro-2014     Aberto                     11:35    26-outubro-2014    Informado

    10004    11:15    27-outubro-2014    Fechado

    Na planilha de controle onde tenho que executar a tarefa consta 5500 registros onde os números da plan1 coluna se repetem mas na plan2 preciso que seja copiado tudo na mesma linha conforme o numero da coluna A.







    domingo, 2 de novembro de 2014 14:05

Respostas

  • No caso do primeiro registro: qual linha será copiada da Plan1 para Plan2? A primeira vez que aparece 10001 ou a segunda vez que aparece 10001?

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

    • Marcado como Resposta fabiosantos11 sexta-feira, 7 de novembro de 2014 15:07
    terça-feira, 4 de novembro de 2014 22:14
    Moderador
  • Sub pMain()
      Dim lLast As Long
      Dim wsOutput As Excel.Worksheet
      Dim wsInput As Excel.Worksheet
      Dim lOutput As Long
      Dim lInput As Long
      Dim lCol As Long
      
      Application.ScreenUpdating = False
      
      With ThisWorkbook
        Set wsOutput = .Worksheets("Plan2")
        Set wsInput = .Worksheets("Plan1")
        wsInput.Copy Before:=.Sheets(1)
        Set wsInput = ActiveSheet
      End With
      
      For lOutput = 2 To wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row
        Do
          lInput = pMatch(wsOutput.Cells(lOutput, "A"), wsInput.Columns("A"))
          If lInput = 0 Then Exit Do
          lCol = wsOutput.Cells(lOutput, wsOutput.Columns.Count).End(xlToLeft).Column + 1
          wsInput.Cells(lInput, "B").Resize(, 8).Copy Destination:=wsOutput.Cells(lOutput, lCol)
          wsInput.Rows(lInput).Delete
        Loop
        DoEvents
      Next lOutput
    
      Application.DisplayAlerts = False
      wsInput.Delete
      Application.DisplayAlerts = True
      
      Application.ScreenUpdating = True
    End Sub
    
    Public Function pMatch(vValue As Variant, _
                           vArray As Variant) As Long
      'Retorna a linha/coluna/índice de um valor encontrado numa coluna/linha/vetor.
      'Retorna 0 se elemento não for encontrado.
      Dim ret As Long
    
      On Error Resume Next
      ret = WorksheetFunction.Match(CDbl(vValue), vArray, 0)
      If ret = 0 Then ret = WorksheetFunction.Match(CStr(vValue), vArray, 0)
      On Error GoTo 0
    
      If ret > 0 Then
        If TypeName(vArray) = "Range" Then
          If vArray.Columns.Count = 1 Then
            ret = vArray(1).Row + ret - 1
          ElseIf vArray.Rows.Count = 1 Then
            ret = vArray(1).Column + ret - 1
          Else
            'A seleção não é um vetor de uma dimensão.
            ret = 0
          End If
        Else
          If TypeName(vArray) Like "*()" Then
            ret = ret + (LBound(vArray) - 1)
          End If
        End If
      End If
    
      pMatch = ret
    End Function
    Faltou o código para criar os cabeçalhos na planilha de saída. Se tiver dificuldades, me diga.

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

    • Marcado como Resposta fabiosantos11 sexta-feira, 7 de novembro de 2014 15:07
    quinta-feira, 6 de novembro de 2014 00:06
    Moderador
  • Não há em que pedir desculpa.

    Experimente colocar a linha de código abaixo para executar após a planilha de saída ter sido preenchida:

    wsOutput.Range("A1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftToLeft


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

    • Marcado como Resposta fabiosantos11 domingo, 16 de novembro de 2014 13:17
    sábado, 15 de novembro de 2014 10:46
    Moderador

Todas as Respostas

  • No caso do primeiro registro: qual linha será copiada da Plan1 para Plan2? A primeira vez que aparece 10001 ou a segunda vez que aparece 10001?

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

    • Marcado como Resposta fabiosantos11 sexta-feira, 7 de novembro de 2014 15:07
    terça-feira, 4 de novembro de 2014 22:14
    Moderador
  • Olá Felipe boa tarde,

    Muito obrigado e desculpe a demora.

    Estava corrido por aqui e estava sem tempo disponível para responder.

    Creio que anexando um modelo da minha planilha fica mais fácil entender.

    https://www.sendspace.com/file/765gd4

    Na minha planilha original existe 5500 registro na Plan1 que deverão ser copiados para Plan2 de acordo com o número que consta na coluna A.

    Abraços.


    • Editado fabiosantos11 quarta-feira, 5 de novembro de 2014 14:57
    quarta-feira, 5 de novembro de 2014 14:43
  • Sub pMain()
      Dim lLast As Long
      Dim wsOutput As Excel.Worksheet
      Dim wsInput As Excel.Worksheet
      Dim lOutput As Long
      Dim lInput As Long
      Dim lCol As Long
      
      Application.ScreenUpdating = False
      
      With ThisWorkbook
        Set wsOutput = .Worksheets("Plan2")
        Set wsInput = .Worksheets("Plan1")
        wsInput.Copy Before:=.Sheets(1)
        Set wsInput = ActiveSheet
      End With
      
      For lOutput = 2 To wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row
        Do
          lInput = pMatch(wsOutput.Cells(lOutput, "A"), wsInput.Columns("A"))
          If lInput = 0 Then Exit Do
          lCol = wsOutput.Cells(lOutput, wsOutput.Columns.Count).End(xlToLeft).Column + 1
          wsInput.Cells(lInput, "B").Resize(, 8).Copy Destination:=wsOutput.Cells(lOutput, lCol)
          wsInput.Rows(lInput).Delete
        Loop
        DoEvents
      Next lOutput
    
      Application.DisplayAlerts = False
      wsInput.Delete
      Application.DisplayAlerts = True
      
      Application.ScreenUpdating = True
    End Sub
    
    Public Function pMatch(vValue As Variant, _
                           vArray As Variant) As Long
      'Retorna a linha/coluna/índice de um valor encontrado numa coluna/linha/vetor.
      'Retorna 0 se elemento não for encontrado.
      Dim ret As Long
    
      On Error Resume Next
      ret = WorksheetFunction.Match(CDbl(vValue), vArray, 0)
      If ret = 0 Then ret = WorksheetFunction.Match(CStr(vValue), vArray, 0)
      On Error GoTo 0
    
      If ret > 0 Then
        If TypeName(vArray) = "Range" Then
          If vArray.Columns.Count = 1 Then
            ret = vArray(1).Row + ret - 1
          ElseIf vArray.Rows.Count = 1 Then
            ret = vArray(1).Column + ret - 1
          Else
            'A seleção não é um vetor de uma dimensão.
            ret = 0
          End If
        Else
          If TypeName(vArray) Like "*()" Then
            ret = ret + (LBound(vArray) - 1)
          End If
        End If
      End If
    
      pMatch = ret
    End Function
    Faltou o código para criar os cabeçalhos na planilha de saída. Se tiver dificuldades, me diga.

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

    • Marcado como Resposta fabiosantos11 sexta-feira, 7 de novembro de 2014 15:07
    quinta-feira, 6 de novembro de 2014 00:06
    Moderador
  • Felipe bom dia.

    Muito obrigado!

    Testei o funcionamento e está atendendo perfeitamente a minha necessidade.

    Apenas uma dúvida.

    Antes na Plan1 tinha informações até a coluna I mas surgiu necessidade de aumentar até a coluna Q e percebi que a macro não copia para Plan2 as informações que estão no intervalo J:Q.

    Desculpe mas poderia informar que parte da macro necessito alterar?

    Segue o link do modelo que criei para compreender melhor minha necessidade.

    https://www.sendspace.com/file/gslcdx

    quinta-feira, 6 de novembro de 2014 11:59
  • Altere a linha:

    wsInput.Cells(lInput, "B").Resize(, 8).Copy Destination:=wsOutput.Cells(lOutput, lCol)

    para:

    wsInput.Cells(lInput, "B").Resize(, 16).Copy Destination:=wsOutput.Cells(lOutput, lCol)


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

    quinta-feira, 6 de novembro de 2014 22:42
    Moderador
  • Felipe Boa Tarde.

    Muito obrigado!

    Esta funcionando perfeitamente.

    Estava tentando ordenar a planilha para melhorar a visualização pois tem alguns números de registros que são preenchidas todas linhas do intervalo B:AO mas tem alguns números de registros que não e fica várias linhas em branco.

    Tentei eliminar as linhas com esta macro que eu sempre usei para outras planilhas mas não surtiu efeito.

    Desculpe ficar postando em partes e que as necessidades vão surgindo conforme vou executando as tarefas.

    Mas será a última dúvida referente a este assunto.

    Sub DeleteBlankRows()
    Dim Rw As Range
    If WorksheetFunction.CountA(Selection) = 0 Then
    MsgBox "No blank rows found", vbOKOnly
    Exit Sub
    End If
    With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    Selection.SpecialCells(xlCellTypeBlanks).Select
    For Each Rw In Selection.Rows
    If WorksheetFunction.CountA(Selection.EntireRow) = 0 Then
    Selection.EntireRow.Delete
    End If
    Next Rw
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    End With
    MsgBox "Nenhuma Linha Vazia encontrada"

    EndSub

    Desde já agradeço sua ajuda e compreensão.

    Abraços.

    sexta-feira, 7 de novembro de 2014 15:06
  • Não entendi sua última necessidade, poderia explicar novamente?

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

    sábado, 8 de novembro de 2014 22:05
    Moderador
  • Boa noite,

    Desculpe por não conseguir me expressar com precisão.

    Creio que verificando o arquivo deste link será mais fácil compreender que desejo fazer.

    https://www.sendspace.com/file/u2lp6z

    Exemplo:

    Número de registro 10001 tem todas as linhas preenchidas do intervalo B:CC

    Mas número de registro 10002 tem dados no intervalo B:Q depois vazio do intervalo R:AO e com dados no intervalo AP:BE

    queria que as informações fique em sequencia depois que fossem copiadas da Plan1 para Plan2 assim no caso do número de registro 10002 puxar dados do intervalo AP:BE para a última linha em branco linha R e assim sucessivamente com todos os números de registros.

    Obrigado.

    Abraços.

    domingo, 9 de novembro de 2014 04:05
  • Sinto muito Fábio, mas não entendi sua explicação, mesmo abrindo o arquivo.

    Melhore o português desta frase:

    "queria que as informações fique em sequencia depois que fossem copiadas da Plan1 para Plan2 assim no caso do número de registro 10002 puxar dados do intervalo AP:BE para a última linha em branco linha R e assim sucessivamente com todos os números de registros."

    Não entendi o que pretende fazer.


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

    domingo, 9 de novembro de 2014 23:18
    Moderador
  • Boa noite Desculpe o transtorno. Para melhorar a visualização necessito que as informações depois de copiadas para a Plan2 fique em sequência. Ex: No caso do número 10001 existe dados em todas linhas. Porém no caso do número 10002 existe dados nas linhas B a Q o intervalo R a AO não tem dados e no intervalo AP a BE contém dados então para não ficar com linhas vazias e depois linhas com dados gostaria de transferir dados das linhas AP:BE para a primeira linha em branco depois do intervalo B:Q assim deixando as informações em sequência e sem intervalos em branco(sem dados). Necessito que essa tarefa seja executada em todos os números. Novamente peço desculpa na falha na comunicação. Abraços.
    segunda-feira, 10 de novembro de 2014 00:13
  • Não há em que pedir desculpa.

    Experimente colocar a linha de código abaixo para executar após a planilha de saída ter sido preenchida:

    wsOutput.Range("A1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftToLeft


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

    • Marcado como Resposta fabiosantos11 domingo, 16 de novembro de 2014 13:17
    sábado, 15 de novembro de 2014 10:46
    Moderador
  • Felipe bom dia!

    Agora está perfeito!!

    Sem palavras para agradecer a sua ajuda.

    Agora todos problemas resolvidos.

    Abraços.

    domingo, 16 de novembro de 2014 13:16