Este fórum está sendo desativado

[ShockWave]

Boa noite pessoal!
É meu primeiro tópico no fórum. Estou enfrentando uma dificuldade na programação da minha "primeira" macro no VBA.

Preciso do seguinte: Copiar as colunas selecionadas (A,B,N,O) e a célula E3(fixada para todas linhas) da aba atual e transferir para a aba "Plan4", e conforme vou indo fazendo isso para cada aba ele vai colando em baixo da ultima célula preenchida. Porém, ele só está transferindo o último range que eu faço. Alguém pode me ajudar a resolver este problema? Obrigado!

Como é a planilha atual:
https://uploaddeimagens.com.br/imagens/ ... d-png--773
Como deve ficar:
https://uploaddeimagens.com.br/imagens/ ... d1-png--20

[alexandrevba]

Bom dia!!
Como eu não tenho permissão para baixar os arquivos e não sei como os dados será colados na guia Plan4, eu tive que deduzir.
No meu código tem a guia Mestre, altere para a guia real do seu caso.

Código: Selecionar todos

Public Sub AleVBA_3150()
Dim ws  As Worksheet, LR1 As Long, LR2 As Long, LR3 As Long
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Mestre" Then
        LR1 = Sheets("Mestre").Range("A" & Rows.Count).End(xlUp).Row + 1
        LR2 = ws.Range("A" & Rows.Count).End(xlUp).Row
        LR3 = ws.Range("N" & Rows.Count).End(xlUp).Row
        ws.Range("E3").Copy Destination:=Sheets("Mestre").Range("E" & Rows.Count).End(xlUp).Offset(1)
        ws.Range("A2:B" & LR2).Copy Destination:=Sheets("Mestre").Range("A" & LR1)
        ws.Range("N2:O" & LR3).Copy Destination:=Sheets("Mestre").Range("N" & LR1)
    End If
Next ws
Application.ScreenUpdating = True
End Sub

Att

[Reinaldo]

Cross: http://www.planilhando.com.br/forum/vie ... 10&t=22020

Código: Selecionar todos

Sub Macro33333()
'
'Macro criada em 27/09/2016

Dim uLin As Integer
uLin = Sheets("Plan4").Cells(Cells.Rows.Count, "B").End(xlUp).Row
'Copiar Código e Descição
Range("A12:B12").Select
    Range(Selection, Selection.End(xlDown)).Select
   Selection.Copy
Sheets("plan4").Range("B" & uLin).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
   
Range("N12").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("plan4").Range("D" & uLin).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
Application.CutCopyMode = False
   
End Sub

[ShockWave]

Reinaldo e Alexandre Muito obrigado! Resolveu 90% do meu problema rsrs. Eu só preciso agora colocar o Nome de cada aba ao lado do texto que foi copiado. o Nome de cada aba se encontra na Célula E3.
Exemplo abaixo:



Obrigado mais uma vez! Desculpe Incomodar.

[alexandrevba]

Bom dia!!

Veja se ajuda.

Código: Selecionar todos

Public Sub AleVBA_3150()
Dim Ws As Worksheet, LR1 As Long, LR2 As Long
Application.ScreenUpdating = False
   For Each Ws In ThisWorkbook.Worksheets
        If Ws.Name <> "Mestre" Then
           LR1 = ThisWorkbook.Worksheets("Mestre").Range("A" & Rows.Count).End(xlUp).Row + 1
           LR2 = Ws.Range("A" & Rows.Count).End(xlUp).Row
           ThisWorkbook.Worksheets("Mestre").Range("E" & LR1).Resize(LR2 - 1).Value = Ws.Name
           Ws.Range("A2:B" & LR2).Copy ThisWorkbook.Worksheets("Mestre").Range("A" & LR1)
           Ws.Range("N2:O" & LR2).Copy ThisWorkbook.Worksheets("Mestre").Range("N" & LR1)
        End If
    Next Ws
Application.ScreenUpdating = True
End Sub

Caso necessário, favor adaptar!

Att