Boa noite Lidiq!
Desculpe o sumiço, mas estive em viagem de trabalho nas últimas 2 semanas e não tive tempo de responder.
Mas acho que minha sugestão talvez lhe ajude. Primeiramente peço licença ao Felipe Costa Gualberto para usar seu código proposto acima, visto que a partir dele fica bem simples resolver o seu problema (se entendi bem o que você precisa). O código que proponho
primeiramente gera o relatório em Abas (Planilhas) e em seguida exporta para Pastas de Trabalho (Arquivos). Sendo assim, segue minha sugestão:
Sub GerarRelatorio()
'
'
Dim lngBD As Long
Dim lngLast As Long
Dim wksBD As Worksheet
Dim wks As Worksheet
Dim Ccod As String 'Coluna com os códigos
Dim Ccod1 As String 'Coluna com os códigos Primários
Dim Ccod2 As String 'Coluna com os códigos Secundários
Dim Lini As Long 'Linha Incial
Dim FilCusto As String 'Identificador de Centro de Custo (ao invés de Filial)
Dim EndArq As String
Dim NomeArq As String
Dim TipoX As String
Dim Atual As String
Dim i As Integer
Ccod1 = "L" 'Filiais
Ccod2 = "J" 'Centro de Custo
Lini = 5 'Após cabeçalho
FilCusto = "999999 Não Operacional" '"999999"
EndArq = ActiveWorkbook.Path 'Edite aqui
TipoX = "xlsx" 'xls 'Edite aqui
'Set wksBD = ThisWorkbook.Sheets("Banco de Dados Geral Dez2012")
Set wksBD = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
With wksBD
For lngBD = Lini To .Cells(.Rows.Count, "A").End(xlUp).Row
Set wks = Nothing
If CStr(.Cells(lngBD, Ccod1)) = FilCusto Then
Ccod = Ccod2
Else
Ccod = Ccod1
End If
On Error Resume Next
Set wks = ThisWorkbook.Sheets(CStr(.Cells(lngBD, Ccod)))
On Error GoTo 0
If wks Is Nothing Then
Set wks = ThisWorkbook.Sheets.Add
wks.Name = CStr(.Cells(lngBD, Ccod))
wksBD.Rows(Lini - 1).Copy wks.Rows(1)
End If
lngLast = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row + 1
wksBD.Rows(lngBD).Copy wks.Rows(lngLast)
Next lngBD
End With
For i = Sheets.Count To 1 Step -1
wksBD.Activate
If Sheets(i).Name <> wksBD.Name Then Call Exportar(EndArq, Sheets(i).Name, TipoX, Sheets(i).Name)
Next i
Application.ScreenUpdating = False
End Sub
Sub Exportar(xEnd, xNome, TipoX, xNomeAba)
'
'Exportas as Abas Criadas
'
' xEnd => Endereço para Salvar
' xNome => Nome para Salvar
' TipoX => xls ou xlsx
' xNomeAba => Nome da Aba Desejada
On Error GoTo FimInesperado
Application.ScreenUpdating = False
EndSalvar = xEnd & "\" & xNome & "." & TipoX 'Endereço completo
If TipoX = "xlsx" Then Formato = xlOpenXMLWorkbook Else Formato = xlNormal 'xlExcel8
'Copiando para nova pasta
Sheets(xNomeAba).Select
ActiveSheet.Move
'Renomeando Aba e Excluindo as demais (Caso existam)
Excel.Application.DisplayAlerts = False 'Desabilitando o pedido de confirmação de exclusão
For i = 2 To Sheets.Count
Sheets(2).Delete 'Tem o Incoveniente de solicitar confirmação sempre que exclui uma aba
Next i
Excel.Application.DisplayAlerts = True 'Reabilitando o pedido de confirmação
'Salvando
ActiveWorkbook.SaveAs Filename:=EndSalvar, _
FileFormat:=Formato, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Fim:
Application.ScreenUpdating = True
'Beep
'MsgBox "Arquivo Exportado!", , "Operação Concluída!"
Exit Sub
FimInesperado:
Application.ScreenUpdating = True
MsgBox "Arquivo NÃO Exportado!" & vbNewLine & Err.Description, vbCritical, "Operação Não Realizada!"
End Sub
Deixo a seu critério criar uma interface para escolha dos nomes dos arquivos, locais para salvar ou características que possam ser alteradas ao longo do trabalho (como as colunas de interesse). Toda a seleção atual é feita no prórpio código.
Dessa forma atende?
Um abraço.
Filipe Magno
Criar novas planilhas a partir do filtro de uma coluna
