none
Ajuda com Macros RRS feed

  • Pergunta

  • Boa tarde!

    Possuo uma planilha com diversos itens, por exemplo:

    A

    B

    C

    Porem, abaixo de cada item, eu preciso inserir 3 linhas com o conteudo da primeira linha, ficando da seguinte forma:

    A

    A

    A

    A

    B

    B

    B

    B

    C

    C

    C

    C

    Alguem tem ideia de ocmo eu poderia realizar essa operação atraves de uma macro?

    domingo, 21 de abril de 2013 17:53

Respostas

  • Sub fMain()
        Dim lng As Long
        
        Application.ScreenUpdating = False
        For lng = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
            Rows(lng).Copy
            Rows(lng).Resize(3).Insert
        Next lng
        Application.ScreenUpdating = True
    End Sub


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

    segunda-feira, 22 de abril de 2013 21:53
    Moderador

Todas as Respostas

  • Boa noite Tarsio.

    Tente o seguinte código:

    Sub ReplicarDados()
    
    Cini = "A"          'Coluna para Averiguação
    Lini = 5            'Linha inicial Após cabeçalho
    
    Application.ScreenUpdating = False
    With ActiveSheet
        For i = Lini To (.Cells(.Rows.Count, Cini).End(xlUp).Row - Lini + 1) * 3 + Lini - 1 Step 3
        
            .Rows(i).Copy
            .Rows(i + 1 & ":" & i + 2).Select
            Selection.Insert Shift:=xlDown
        Next i
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    End Sub

    Resolve dessa forma?

    Vlw.


    Filipe Magno


    • Editado FilipeMagno domingo, 21 de abril de 2013 23:37 Correção
    • Sugerido como Resposta FilipeMagno segunda-feira, 24 de junho de 2013 16:12
    domingo, 21 de abril de 2013 23:36
  • Sub fMain()
        Dim lng As Long
        
        Application.ScreenUpdating = False
        For lng = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
            Rows(lng).Copy
            Rows(lng).Resize(3).Insert
        Next lng
        Application.ScreenUpdating = True
    End Sub


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

    segunda-feira, 22 de abril de 2013 21:53
    Moderador