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

Question

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

Answer 1

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

Answer 2

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.

Answer 3

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