none
Macro para criar nova pasta de trabalho com as planilhas determinadas RRS feed

  • 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
    quarta-feira, 22 de outubro de 2014 00:05

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

    sexta-feira, 24 de outubro de 2014 21:44
    Moderador

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

    quarta-feira, 22 de outubro de 2014 00:47
  • 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

    sexta-feira, 24 de outubro de 2014 21:44
    Moderador