Esqueceu sua senha? Você pode usar o mecanismo de lembrete neste link: Recuperar senha

Você receberá um link de reativação no email cadastrado.

Não recebeu o email? Lembre-se checar o Lixo Eletrônico.

Copiar e copiar em varias linhas

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
FitaD
Acabou de chegar
Acabou de chegar
Mensagens: 1
Registrado em: Ter Jul 09, 2019 2:21 am

Copiar e copiar em varias linhas

Mensagem por FitaD » Sáb Jul 13, 2019 6:07 am

Estou precisando de uma macro que copie da Plan1 e cole na Plan2 repetindo 5 linhas. Os dados a copiar estão na Plan1 numa tabela que começa em B3 e termina em B102. Queria que corresse toda a tabela e copiasse sempre que a coluna B tivesse valor

Plan1 Copiar :

B3 E3 F3

B4 E4 F4
...
Plan2 Colar:

F2 G2 H2
F3 G3 H3
F4 G4 H5
F6 G6 H6
F7 G7 H7

F8 G8 H8
F9 G9 H9
F10 G10 H10
F11 G11 H11
F12 G12 H12
...

https://1drv.ms/x/s!AsGq2_JdxGwDhGy95TQ2nFZrMvZu



Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


srobles
Jedi
Jedi
Mensagens: 759
Registrado em: Qua Mai 06, 2015 7:39 pm

Re: Copiar e copiar em varias linhas

Mensagem por srobles » Qui Ago 01, 2019 2:11 pm

FitaD,

Veja se a rotina abaixo atende sua necessidade.

Código: Selecionar todos

Sub copiaRange()
    Dim rangeCopia As Range
    Dim linhaAtual As Long, linhaFinal As Long
    Dim novaLinha As Long
    Dim contador As Long
    Dim nomePlan As String
    
    nomePlan = ""
    With ThisWorkbook
        .Sheets.Add After:=.Sheets(Sheets.Count)
        
        With .Sheets(Sheets.Count)
            .Activate
            
            Range("A1") = "nr"
            Range("B1") = "tipo"
            Range("C1") = "rua"
            Range("D1") = "caixa"
            
            ActiveSheet.Name = "Transferência" & ThisWorkbook.Sheets.Count
            nomePlan = "Transferência" & ThisWorkbook.Sheets.Count
        End With
        
        With .Sheets("Plan1")
            linhaAtual = 2
            linhaFinal = .Cells(Rows.Count, 2).End(xlUp).Row
            
            While linhaAtual <= linhaFinal
                .Activate
                If .Cells(linhaAtual, 2) <> Empty Then
                    If .Cells(linhaAtual, 3) <> Empty And .Cells(linhaAtual, 4) <> Empty Then
                        contador = 1
                        
                        Set rangeCopia = Range("B" & linhaAtual & ":E" & linhaAtual)
                        
                        novaLinha = ThisWorkbook.Sheets(nomePlan).Cells(Rows.Count, 1).End(xlUp).Row + 1
                        
                        While Not contador = 6
                            With rangeCopia
                                .Copy ThisWorkbook.Sheets(nomePlan).Cells(novaLinha, 1)
                            End With
                            contador = contador + 1
                            novaLinha = ThisWorkbook.Sheets(nomePlan).Cells(Rows.Count, 1).End(xlUp).Row + 1
                        Wend
                    End If
                End If
                contador = 1
                linhaAtual = linhaAtual + 1
            Wend
        End With
    End With
    MsgBox "Operação realizada com sucesso!", vbInformation, "Transferir dados"
End Sub


Espero ter ajudado.

Abs.

Saulo Robles


Remember when you were young?
You shone like the sun.
Shine On You Crazy Diamond


Se suas dúvidas foram esclarecidas, acrescente ao lado do título o texto [RESOLVIDO].

Responder