Usuário com melhor resposta
Macro para criar nova pasta de trabalho com as planilhas determinadas

Pergunta
-
Boa noite pessoal!
Preciso de um grande favor.
Tenho um arquivo (Pasta de Trabalho do Excel) que contém várias planilhas. a primeira contém uma lista de clientes na coluna A o número de pedidos pendentes na coluna B.
Na Coluna C eu coloquei uma fórmula que repete o código do cliente presente na coluna A somente se houver pedidos pendentes. Se não tiver pedidos pendentes, a célula fica vazia ("", dois pares de aspas na fórmula condicional).
Na coluna D, célula D2, coloquei o nome do arquivo que quero salvar, como no exemplo abaixo:
Coluna A|Coluna B|Coluna C|Coluna D
Cliente|PedPend|Cliente a Relatar|Nome do Novo Arquivo
15792|2|15792 |Pendencias em 31-ago-2014
15684|0|
17164|0|
18328|3|18328
19586|0|
19986|1|19986
...
Para cada cliente há uma planilha com o nome idêntico ao código que está listado na coluna A (que também estará na coluna C se houver pedidos pendentes).
Eu preciso de uma macro que crie um novo arquivo (nova pasta de trabalho), copie para ele as planilhas que aparecem na coluna C (que são os clientes com pedidos pendentes) e, em seguida, salve com o nome informado na célula D2, no mesmo diretório do arquivo atual.
É importante que essa macro vá varrendo a coluna C até ao menos a linha 80 e copie para a nova pasta de trabalho todas as planilhas cujo nome coincida com os nomes listados na coluna C. Também é importante que as planilhas não sejam removidas das pasta de trabalho atual, mas apenas copiadas.
Como sou novato no uso das macros, preciso mais uma vez recorrer à experiência dos experts.
Desde já agradeço pela colaboração.
Até logo!
- Editado LAMac quarta-feira, 22 de outubro de 2014 00:08
Respostas
-
Sub pMain() Dim lLast As Long Dim lRow As Long Dim wkbOut As Excel.Workbook Dim wsCliente As Excel.Worksheet Dim wsList As Excel.Worksheet 'Altere abaixo o nome da planilha que contém a lista de códigos Set wsList = ThisWorkbook.Worksheets("Plan1") Set wkbOut = Workbooks.Add(xlWBATWorksheet) With wsList lLast = .Cells(.Rows.Count, "C").End(xlUp).Row For lRow = 2 To lLast If .Cells(lRow, "C") <> "" Then Set wsCliente = Nothing On Error Resume Next Set wsCliente = ThisWorkbook.Worksheets(.Cells(lRow, "C").Value) On Error GoTo 0 If Not wsCliente Is Nothing Then wsCliente.Copy After:=wkbOut.Worksheets(wkbOut.Sheets.Count) Else MsgBox "Planilha não encontrada na pasta de trabalho de origem: " & .Cells(lRow, "C"), vbExclamation End If End If Next lRow 'Apaga planilha em branco: If wkbOut.Worksheets.Count > 1 Then Application.DisplayAlerts = False wkbOut.Worksheets(1).Delete Application.DisplayAlerts = True End If 'Salva pasta de trabalho de saída: wkbOut.SaveAs ThisWorkbook.Path & "\" & .Range("D2") End With End Sub
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
- Marcado como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 15 de novembro de 2014 10:57
Todas as Respostas
-
LaMac...
tenta com isso....
Private Sub CommandButton1_Click() 'cria as variaveis e objetos Dim wkb As Workbook Dim wks As Worksheet, sht As Worksheet Dim x As Long, y As Long Set wks = ThisWorkbook.Sheets("Plan1") 'define o nome da guia onde seus dados estao y = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row 'identifica a ultima linha da planilha For x = 2 To y 'cria um laço em todas as linhas prenchidas, considerando o inicio na linha 2 If wks.Cells(x, 3).Value <> "" Then For Each sht In ThisWorkbook.Sheets If sht.Name Like "*" & wks.Cells(x, 3).Value & "*" Then 'verifica se o nome da guia contem parte do texto na coluna C Set wkb = Workbooks.Add 'cria uma nova pasta de trabalho sht.Copy wkb.Sheets(1) 'Copia a guia On Error Resume Next Application.DisplayAlerts = False 'desabilita os alertas wkb.Sheets(Array("Plan1", "Plan2", "Plan3")).Delete 'exclui as guias criadas por padrão Application.DisplayAlerts = True 'habilita os alertas On Error GoTo 0 wkb.SaveAs ThisWorkbook.Path & "\" & wks.Cells(x, 4).Value 'salva a pasta de trabalho na mesma pasta do arquivo atual com o nome que está na coluna D wkb.Close 'fecha a pasta de trabalho End If Next sht End If Next x End Sub
Abraço!
Natan
-
Sub pMain() Dim lLast As Long Dim lRow As Long Dim wkbOut As Excel.Workbook Dim wsCliente As Excel.Worksheet Dim wsList As Excel.Worksheet 'Altere abaixo o nome da planilha que contém a lista de códigos Set wsList = ThisWorkbook.Worksheets("Plan1") Set wkbOut = Workbooks.Add(xlWBATWorksheet) With wsList lLast = .Cells(.Rows.Count, "C").End(xlUp).Row For lRow = 2 To lLast If .Cells(lRow, "C") <> "" Then Set wsCliente = Nothing On Error Resume Next Set wsCliente = ThisWorkbook.Worksheets(.Cells(lRow, "C").Value) On Error GoTo 0 If Not wsCliente Is Nothing Then wsCliente.Copy After:=wkbOut.Worksheets(wkbOut.Sheets.Count) Else MsgBox "Planilha não encontrada na pasta de trabalho de origem: " & .Cells(lRow, "C"), vbExclamation End If End If Next lRow 'Apaga planilha em branco: If wkbOut.Worksheets.Count > 1 Then Application.DisplayAlerts = False wkbOut.Worksheets(1).Delete Application.DisplayAlerts = True End If 'Salva pasta de trabalho de saída: wkbOut.SaveAs ThisWorkbook.Path & "\" & .Range("D2") End With End Sub
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
- Marcado como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 15 de novembro de 2014 10:57