Vídeo recomendado
https://youtu.be/diWPPPhW-9E

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 »

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: 805
Registrado em: Qua Mai 06, 2015 7:39 pm

Re: Copiar e copiar em varias linhas

Mensagem por srobles »

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


Responder