Notifications

Clear all

Vba - copiar e colar linha inteira em outra planilha

2024 - VBA & Macros

Post Recente por gilson-bsb 10 anos atrás

5 Posts

2 Usuários

0 Reactions

988 Visualizações

RSS

gilson-bsb

(@gilson-bsb)

Posts: 3

New Member

Topic starter

Pessoal, estou com uma dúvida simples mas não consigo desenvolve-la, o código abaixo seleciona uma linha que tem dados semelhantes na primeira coluna, gostaria apenas de pegar estes dados e copiar a linha inteira para outra planilha:

Public Sub Verifica()

Dim Col As Integer
Dim r As Long
Dim C As Range
Dim N As Long
Dim V As Variant
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Col = ActiveCell.Column

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If

N = 0
For r = Rng.Rows.Count To 1 Step -1
V = Rng.Cells(r, 1).Value
If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
Rng.Rows(r).Interior.ColorIndex = 36
Rng.Rows(r).Select
N = N + 1
End If

' Este é o trecho que estava tentando desenvolver para colar a linha selecionada em Rng.Row®

Selection.Copy
Sheets("Plan2").Select ' Chama a "Plan2"
'Range("A1").Select 'Seleciona a Linha 1 Da primeira Coluna
ActiveSheet.Paste 'Cola os valores selecionados da outra planilha

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Exemplo da planilha, os dados repetidos da primeira coluna são selecionados de amarelo:

25332 JOAO 456325 45
25332 JOAO 456325 45
45333 MARIA 45689 35
48632 JOSE 45899 32
12356 CARLOS 32565 25
12356 CARLOS 32565 25

Abraço

Postado : 06/05/2015 4:58 pm

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Veja se é isto :

Public Sub Verifica()
    Dim Col As Integer
    Dim r As Long
    Dim C As Range
    Dim N As Long
    Dim V As Variant
    Dim Rng As Range
    
    On Error GoTo EndMacro
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Col = ActiveCell.Column

    If Selection.Rows.Count > 1 Then
        Set Rng = Selection
    Else
        Set Rng = ActiveSheet.UsedRange.Rows
    End If

    N = 0
    For r = Rng.Rows.Count To 1 Step -1
        
        V = Rng.Cells(r, 1).Value
        
        If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
            Rng.Rows(r).Interior.ColorIndex = 36
            
            'Rng.Rows(r).Select - não precisa selecionar
            Rng.Rows(r).Copy Destination:=Sheets("Plan2").Range("A1") 'copiamos diretamente
            
            N = N + 1
        End If
    
EndMacro:
    
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
    Next
    
End Sub

[]s

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

Postado : 06/05/2015 5:57 pm

gilson-bsb

(@gilson-bsb)

Posts: 3

New Member

Topic starter

Boa noite Mauro Coutinho, obrigado pela sua resposta, mas quando executo o código ele copia apenas o primeiro conteúdo para célula A1, os demais não são copiados, o que estaria acontecendo?

Postado : 12/05/2015 6:03 pm

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Gilson, acabei me pegando quando disse que precisava copiar UMA linha e não incrementei para mais de uma, tente assim :

Nesta linha era copiado somente para o Range A1
Rng.Rows(r).Copy Destination:=Sheets("Plan2").Range("A1")

Aqui incrementei com a variável "X" para as linhas encontradas:
Rng.Rows(r).Copy Destination:=Sheets("Plan2").Cells(X, 1)

Public Sub Verifica()
    Dim Col As Integer
    Dim r As Long
    Dim C As Range
    Dim N As Long
    Dim X As Long
    Dim V As Variant
    Dim Rng As Range
    
    On Error GoTo EndMacro
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Col = ActiveCell.Column

    If Selection.Rows.Count > 1 Then
        Set Rng = Selection
    Else
        Set Rng = ActiveSheet.UsedRange.Rows
    End If

    N = 0
    X = 1 'Linha Inicial na Plan2
    For r = Rng.Rows.Count To 1 Step -1
        
        V = Rng.Cells(r, 1).Value
        
        If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
            Rng.Rows(r).Interior.ColorIndex = 36
            
            Rng.Rows(r).Copy Destination:=Sheets("Plan2").Cells(X, 1) 'copiamos diretamente
            
            N = N + 1
            X = X + 1
        End If
    
EndMacro:
    
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
    Next
    
End Sub

G
Faça os testes e veja se é isto, se for de como Resolvido e clique na mãozinha agradecendo.
[]s

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

Postado : 12/05/2015 8:21 pm