Copiar Dados de VARIAS Planilhas para uma só Planilha

Bom dia!!

Aqui segue exemplo de como copiar dados de VARIAS planilhas para uma só planilha!

Código:

Option Explicit

Sub ConsolidarPlanilhas()
'Author:    Jerry Beaucaire
'Date:      6/26/2009
'Updated:  6/23/2010
'Merge all sheets in a workbook into one summary sheet (stacked)
'Data is sorted by a specific column name
Dim cs As Worksheet, ws As Worksheet
Dim LR As Long, NR As Long, sCol As Long
Dim sName As Boolean, SortStr As String
Application.ScreenUpdating = False

'From the headers in data sheets, enter the column title to sort by when finished
SortStr = "Nome"

'Add consolidation sheet if needed
If Not Evaluate("ISREF(PlanFinal!A1)") Then _
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "PlanFinal"

'Option to add sheet names to consolidation report
sName = MsgBox("Adicione o nome da folha de relatório de PlanFinal?", vbYesNo + vbQuestion) = vbYes

'Setup
Set cs = ActiveWorkbook.Sheets("PlanFinal")
cs.Cells.ClearContents
NR = 1

'Process each data sheet
    For Each ws In Worksheets
        If ws.Name <> cs.Name Then
            LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            'customize this section to copy what you need
            If NR = 1 Then
              'copy titles and data to start the consolidation, edit row as needed for source of titles
                ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Copy
                If sName Then
                    cs.Range("B1").PasteSpecial xlPasteAll
                Else
                    cs.Range("A1").PasteSpecial xlPasteAll
                End If
                NR = 2
            End If
           
            ws.Range("A2:BB" & LR).Copy    'copy data, edit as needed for the start row

            If sName Then      'paste and add sheet names if required
                cs.Range("B" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                cs.Range("A" & NR, cs.Range("B" & cs.Rows.Count).End(xlUp).Offset(0, -1)) = ws.Name
            Else
                cs.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
            End If
           
            NR = cs.Range("A" & cs.Rows.Count).End(xlUp).Row + 1
        End If
    Next ws

'Sort
    LR = cs.Range("A" & cs.Rows.Count).End(xlUp).Row
    On Error Resume Next
    sCol = cs.Cells.Find(SortStr, After:=cs.Range("A1"), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Column
    cs.Range("A1:BB" & LR).Sort Key1:=cs.Cells(2, sCol + (IIf(sName, 1, 0))), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Cleanup
    If sName Then cs.[A1] = "PlanFinal"
    cs.Rows(1).Font.Bold = True
    cs.Cells.Columns.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    cs.Activate
    Range("A1").Select
    Set cs = Nothing
End Sub


Tenham um bom dia!!
Att

Bom dia.

Muito bom esse código ! Realmente eu estava precisando de algo nesse sentido.

Obrigado por publicar esse exemplo.


Abs.

Bom dia!!

Quem bom que foi útil, estaremos disposto ajudar, até a próxima!!

Att

alexandrevba escreveu:Bom dia!!

Quem bom que foi útil, estaremos disposto  ajudar, até a próxima!!

Att

Ola Alexandre,

O código é bem interessante, mas como fazer para que ele pegue apenas as abas que desejo e não todas que estão na planilha.

Abs

Boa noite!!

Você pode criar uma matriz.

Código:

Sheets(Array("Plan1", "Plan2", "Plan3", "Plan4", "Plan5")).Copy

Ola amigos,

Em que parte do codigo eu devo introduzir este codigo?
Obrigado.

Abraços.

alexandrevba escreveu:Boa noite!!

Você pode criar uma matriz.

Código:

Sheets(Array("Plan1", "Plan2", "Plan3", "Plan4", "Plan5")).Copy

Bom dia!!

Tente

Código:

Option Explicit

Sub ConsolidarPlanilhas()
'Author:    Jerry Beaucaire
'Date:      6/26/2009
'Updated:  6/23/2010
'Merge all sheets in a workbook into one summary sheet (stacked)
'Data is sorted by a specific column name
Dim cs As Worksheet, ws As Worksheet
Dim LR As Long, NR As Long, sCol As Long
Dim sName As Boolean, SortStr As String
Application.ScreenUpdating = False

'From the headers in data sheets, enter the column title to sort by when finished
SortStr = "Nome"

'Add consolidation sheet if needed
If Not Evaluate("ISREF(PlanFinal!A1)") Then _
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "PlanFinal"

'Option to add sheet names to consolidation report
sName = MsgBox("Adicione o nome da folha de relatório de PlanFinal?", vbYesNo + vbQuestion) = vbYes

'Setup
Set cs = Sheets("PlanFinal")
cs.Cells.ClearContents
NR = 1

'Process each data sheet
      For Each ws In Sheets(Array("Plan3", "Plan4"))
   
            LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            'customize this section to copy what you need
            If NR = 1 Then
              'copy titles and data to start the consolidation, edit row as needed for source of titles
                ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Copy
                If sName Then
                    cs.Range("B1").PasteSpecial xlPasteAll
                Else
                    cs.Range("A1").PasteSpecial xlPasteAll
                End If
                NR = 2
            End If
           
            ws.Range("A2:BB" & LR).Copy    'copy data, edit as needed for the start row

            If sName Then      'paste and add sheet names if required
                cs.Range("B" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                cs.Range("A" & NR, cs.Range("B" & cs.Rows.Count).End(xlUp).Offset(0, -1)) = ws.Name
            Else
                cs.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
            End If
           
            NR = cs.Range("A" & cs.Rows.Count).End(xlUp).Row + 1
     
    Next ws

'Sort
    LR = cs.Range("A" & cs.Rows.Count).End(xlUp).Row
    On Error Resume Next
    sCol = cs.Cells.Find(SortStr, After:=cs.Range("A1"), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Column
    cs.Range("A1:BB" & LR).Sort Key1:=cs.Cells(2, sCol + (IIf(sName, 1, 0))), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Cleanup
    If sName Then cs.[A1] = "PlanFinal"
    cs.Rows(1).Font.Bold = True
    cs.Cells.Columns.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    cs.Activate
    Range("A1").Select
    Set cs = Nothing
End Sub

Como faço para copiar os dados de células específicas de varias planilhas e colocá-las em colunas em uma unica planilha?

Bom dia!!

Abra um tópico especificando detalhadamente sua dúvida, poste um arquivo modelo exemplificando.

Att

Senhores, bom dia... realmente este comando é fantastico.
Mas deparei me que a mesma não copia todos os dados da planilha.
No meu exemplo que utilizo a macro está copiando somente 68 linhas e quando possui mais linhas as mesmas não são copiadas.
Poderia me assessorar neste detalhe?
O que devo mudar na macro para copiar todos os dados que estão dentro da guia?
Obrigado.

Boa tarde!!

O ideal é abrir um post nele postar seu arquivo!!


Att

Alexandre consegui resolver o problema acima listado... agora o que está pegando é que eu tenho que analisar cerca de 300 guias que está em uma pasta do excel, consegui buscar os dados para uma guia só e ficou perfeito. Só que as guias possuem o comando de agrupar e desagrupar para linhas e colunas e quando coloco a macro para rodar ela não pega os valores que estão agrupados. Teria como criar uma macro para entrar dentro de cada guia e eliminar este comando de "agrupar e desagrupar"?
Infelizmente não posso compartilhar meu arquivo por politicas da empresa...
Espero que tenha entendido minha dúvida.

Bom dia!!

Abrar um tópico separado quando for falar de um assunto não relacionado com este tópico, isso ajuda a manter o fórum organizado!!

Você não precisa mandar seu arquivo original mande um modelo contendo dados fictícios!!

Se gravar uma macro vera que pode desagrupar as linhas

Código:

Sub Macro1()
    Cells.Select
    Selection.Rows.Ungroup
End Sub

Bom dia.

Tenho uma dúvida com relação a seu código, é exatamente o que eu preciso, mas devido a grande quantidade de pastas e o grande conteúdo que possui em cada uma delas, fica bem pesado para a criação dessa nova pasta.

Há a possibilidade de se criar um novo arquivo com todo o conteúdo?