Macro para criar nova pasta de trabalho com as planilhas determinadas

Question

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!

Answer 1

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

Answer 2

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