none
Separar Workbook com várias planilhas em novos arquivos com 2 worksheets cada. RRS feed

  • Pergunta

  • Pessoal,

    Estou começando com VBA agora e preciso muito de uma ajuda para alterar o laço de repetição.

    No código abaixo eu utilizo o comando For Each que separa cada planilha e salva em um arquivo novo, pois bem... eu preciso que o algoritmo salve 2 planilhas em um novo arquivo... alguém pode me ajudar? Vejam o código que estou utilizando.

    Como mencionei, tentei de diversas utilizar outros comando de repetição, mas não consegui.

    Public Sub SplitSheetsToWorkbook()
        On Error GoTo TrataErro
     
        'variáveis
        Dim newBook As Workbook
        Dim sheet As Worksheet
        Dim i As Byte
     
        'Desativa os avisos e atualiação da tela
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
     
        For Each sheet In ThisWorkbook.Worksheets
            'cria uma nova pasta de trabalho:
            Set newBook = Application.Workbooks.Add
            'copia a planilha
            sheet.Copy Before:=newBook.Sheets(1)
                   
            
            'remove as outras
            For i = 2 To newBook.Worksheets.Count
                newBook.Worksheets(2).Delete
            Next i
            'salva o arquivo
            newBook.SaveAs Replace(ThisWorkbook.FullName, ThisWorkbook.Name, vbNullString) & sheet.Name & ".xlsx"
            newBook.Close
        Next sheet
     
    TrataSaida:
        'Reativa os avisos e atualiação da tela
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
     
        'zera as variáveis
        Set newBook = Nothing
        Set sheet = Nothing
     
        MsgBox "Feito!"
        Exit Sub
     
    TrataErro:
        MsgBox Err.Description, vbCritical, "Erro"
     
        GoTo TrataSaida
    End Sub



    • Editado alyssonext terça-feira, 12 de novembro de 2013 13:15
    terça-feira, 12 de novembro de 2013 13:15

Respostas

  • Sub fnc()
      Dim wks As Excel.Worksheet
      Dim wkb As Excel.Workbook
      Dim wkbActive As Excel.Workbook
      Dim lng As Long
      Dim strWorkbookName As String
      
      Set wkbActive = ActiveWorkbook
      If wkbActive.Path = "" Then
        MsgBox "Salve esta pasta de trabalho antes de executar esta rotina!", vbCritical
        Exit Sub
      End If
      
      For lng = 1 To wkbActive.Worksheets.Count Step 2
        wkbActive.Worksheets(lng).Copy
        Set wkb = Workbooks(Workbooks.Count)
        On Error Resume Next
        wkbActive.Worksheets(lng + 1).Copy After:=wkb.Worksheets(wkb.Worksheets.Count)
        strWorkbookName = wkb.Worksheets(1).Name
        strWorkbookName = strWorkbookName & wkb.Worksheets(2).Name
        wkb.SaveAs wkbActive.Path & "\" _
        & strWorkbookName _
        , xlOpenXMLWorkbook
        On Error GoTo 0
        wkb.Close
      Next lng
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 20 de novembro de 2013 18:26
    Moderador

Todas as Respostas

  • Não entendi bem quais seriam as duas planilhas. Uma da pasta de trabalho de origem e outra em branco?

    O exemplo a seguir salva uma planilha em cada pasta de trabalho diferente:

    Sub fnc()
      Dim wks As Excel.Worksheet
      Dim wkb As Excel.Workbook
      Dim wkbActive As Workbook
      
      Set wkbActive = ActiveWorkbook
      If wkbActive.Path = "" Then
        MsgBox "Salve esta pasta de trabalho antes de executar esta rotina!", vbCritical
        Exit Sub
      End If
      
      For Each wks In wkbActive.Worksheets
        wks.Copy
        Set wkb = Workbooks(Workbooks.Count)
        wkb.SaveAs wkbActive.Path & "\" & wks.Name, xlOpenXMLWorkbook
        wkb.Close
      Next wks
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    • Marcado como Resposta alyssonext terça-feira, 12 de novembro de 2013 23:32
    • Não Marcado como Resposta alyssonext terça-feira, 12 de novembro de 2013 23:32
    terça-feira, 12 de novembro de 2013 22:27
    Moderador
  • Felipe,

    É... acho que não fui muito claro mesmo. 

    O problema é o seguinte... Eu quero que ele sempre salve em uma pasta de trabalho nova duas planilhas do meu arquivo atual.

    Eu tenho uma pasta de trabalho com N planilhas: "Original Books","Original Details", "EmpresaA-Books","EmpresaA-Details","EmpresaB-Books","EmpresaB-Details"....

    Preciso que o algoritmo salve as duas primeiras planilhas em uma nova pasta de trabalho, as duas seguintes em uma nova pasta e assim por diante... 

    Não sei como fazer.




    • Editado alyssonext terça-feira, 12 de novembro de 2013 23:28
    terça-feira, 12 de novembro de 2013 22:52
  • Sub fnc()
      Dim wks As Excel.Worksheet
      Dim wkb As Excel.Workbook
      Dim wkbActive As Excel.Workbook
      Dim lng As Long
      Dim strWorkbookName As String
      
      Set wkbActive = ActiveWorkbook
      If wkbActive.Path = "" Then
        MsgBox "Salve esta pasta de trabalho antes de executar esta rotina!", vbCritical
        Exit Sub
      End If
      
      For lng = 1 To wkbActive.Worksheets.Count Step 2
        wkbActive.Worksheets(lng).Copy
        Set wkb = Workbooks(Workbooks.Count)
        On Error Resume Next
        wkbActive.Worksheets(lng + 1).Copy After:=wkb.Worksheets(wkb.Worksheets.Count)
        strWorkbookName = wkb.Worksheets(1).Name
        strWorkbookName = strWorkbookName & wkb.Worksheets(2).Name
        wkb.SaveAs wkbActive.Path & "\" _
        & strWorkbookName _
        , xlOpenXMLWorkbook
        On Error GoTo 0
        wkb.Close
      Next lng
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 20 de novembro de 2013 18:26
    Moderador