Código para copiar e salvar resultado do vba em um novo excel

RONALDO_FLASH · 19 de outubro de 2016

olá pessoal, bem??

estou com uma duvida em um código VBA e preciso da ajuda de vocês.

tenho o seguinte código:

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 da Planilha principal
Dim LiniAbas As Long    'Linha Incial das Abas a Exportar
Dim FilCusto As String  'Identificador de Centro de Custo (ao invés de Filial)
Dim EndArq As String
Dim EndArq1 As String
Dim EndArq2 As String
Dim NomeArq As String
Dim TipoX As String
Dim Atual As String
Dim i As Integer
Dim nSh As Integer

'Dados de Configuração:
'>>
Ccod1 = "A"             'Filiais
Ccod2 = "J"             'Centro de Custo
Lini = 2                'Após cabeçalho na Planilha principal
LiniAbas = 2            'Após cabeçalho nas Abas a Exportar



EndArq1 = ActiveWorkbook.Path                           'Edite aqui
EndArq2 = ActiveWorkbook.Path & "\Não Operacional"      'Edite aqui
TipoX = "xlsx"       'xls                               'Edite aqui
'<<

Set wksBD = ThisWorkbook.ActiveSheet

Application.ScreenUpdating = False

nSh = Sheets.Count 'ActiveSheet.Index   'Para não exportar as abas já existentes!

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
            ThisWorkbook.Sheets.Add Before:=Sheets(1)
            Set wks = ActiveSheet
            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 - nSh To 1 Step -1
    'wksBD.Activate
    If Sheets(i).Range(Ccod1 & LiniAbas) <> FilCusto Then
       
        EndArq = EndArq1    'Pasta Padrão
    Else
        EndArq = EndArq2    'Pasta Especial
    End If
   
    Call Exportar(EndArq, Sheets(i).Name, TipoX, Sheets(i).Name)
   
Next i

Application.ScreenUpdating = False
End Sub

esse código pega da minha sheet principal todos os registros de cada grupo e vai criando uma nova sheet para cada grupo..

é exatamente o que preciso, porém, preciso que a cada sheet que é criada, seja salva em uma nova pasta de Excel..(Excel novo) em uma pasta em minha desktop.... porém, essa parte de salvar o resultado q não está ok. ele cria as sheets porém sem exportar o resultado e salvar na pasta q preciso (veja acima na parte Call Exportar) .

Como copiei aqui do fórum esse código, talvez esteja esquecendo de algo.

Outra dúvida, esse meu arquivo contem muitos registros, ceca de 360mil linhas... e preciso separar por grupos como já está fazendo, são mais ou menos 350 grupos..

é possível pelo VBA ? o Excel suporta esse tanto de sheet e esse código?

como teste, fiz um uma planilha separada apenas alguns dos grupos... O código funciona quando comento a parte do (Call Exportar) porém, ele criar as sheets corretamente, mas não exporta... que a parte que preciso..

valeu galera... e tomara q consigam me ajudar....

abs,