none
CÓDIGO PARA COPIAR E SALVAR RESULTADO DO VBA EM UM NOVO EXCEL RRS feed

  • Pergunta

  • olá pessoal, bem??

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

    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,


    • Editado Ro_flash terça-feira, 18 de outubro de 2016 22:44
    terça-feira, 18 de outubro de 2016 22:44

Todas as Respostas