Alexandre, bom dia.
Primeiramente gostaria de agradecer o suporte prestado. Inseri o código e apontei para um botão, mas o resultado não chegou no esperado. Na consolidação dos dados ele acabou copiando apenas o primeiro nome de cada planilha. Eu encontrei um código e gostaria de ajuda para ajusta-lo.
Esse código ele pede para você apontar o(s) arquivo(s) e depois disso ele faz um laço de repetição copiando os dados de todas as planilhas dos vendedores para a matriz.
A única coisa que preciso ajustar é o seguinte: Não sei quantas abas vou ter dentro de cada arquivo e o laço pede o numero exato de abas para percorrer e também ele não deixa eu selecionar o intervalo desejado a ser copiado que seria A6:P224 de cada aba percorrida.
Segue o código:
Sub BuscarInformações()
Dim wb As Workbook
Dim ws As Worksheet
Dim lngRemoto As Long
Dim lngEu As Long
Dim lngCounter As Long
Application.ScreenUpdating = False
With ActiveSheet
For lngCounter = 1 To 6
Set wb = Workbooks.Open(Application.GetOpenFilename)
Set ws = wb.Sheets(1)
lngEu = .Cells(.Rows.Count, "A").End(xlUp).Row
lngRemoto = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range(IIf(lngRemoto - 9 < 1, 1, lngRemoto - 9) & ":" & lngRemoto).EntireRow.Copy Destination:=.Range("A" & lngEu + 1)
wb.Close False
Next lngCounter
End With
Set ws = Nothing
Set wb = Nothing
Application.ScreenUpdating = True
End Sub
gallilleu
Membro
Membro
Mensagens: 2
Registrado em: Hoje, 08:41
Agradeceu : 0 time
Foi agradecido: 0 time
Bom dia!!
Se pesquisa na nossa base de dados, encontrara ajuda.
Pode ser de uma forma bem simples?
No seu arquivo (BancoDados.xls), ponha o código abaixo, esse código copiará todas guias para uma única guia, depois pegue essa única guia e leve para seu outro arquivo(Gestores.xls)
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 = "Cod"
'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
Att
Postado : 26/12/2013 7:50 am