none
Empaquei numa macro VBA RRS feed

  • Pergunta

  • Boa tarde a todos

    Gostaria de uma ajuda na macro Excel VB para melhorar o seguinte:

    Sub csvfile()
    Sheets("29").Activate
        Dim fs As Object, a As Object, i As Integer, s As String, t As String, l As String, mn As String
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set a = fs.CreateTextFile("SPED EFD" + A1 + ".txt", True)
         
        For r = 1 To Range("A65536").End(xlUp).Row
            s = ""
            c = 1
            While Not IsEmpty(Cells(r, c))
                s = s & Cells(r, c) & ""
                c = c + 1
            Wend
            a.writeline s 'write line
        Next r
         
    End Sub

    Era pra ser uma coisa bem simples só que o volume de planilhas foi aumentando gradativamente.

     Agora preciso que esta macro acima grave cada plan num arquivo texto levando o nome dela no diretório padrão [Set a = fs.CreateTextFile("SPED EFD" + A1 + ".txt", True)]

    -> Neste caso tenho que substituir o A1 pelo nome planilhas em cada arquivo texto.

    Se ajudar tenho relacionados os nomes delas na primeira planilha.

    Mas o principal é que a macro copie todo o conteudo de todas as planilhas em cada arquivo texto sem sobregravá-los pois com esta que criei tenho que selecionar ela manualmente pra depois salvar. E só salva com o mesmo nome de arquivo.

    Antecipadamente agradeço

    Fábio


    FábioNinja

    segunda-feira, 2 de julho de 2012 19:32

Respostas

  • Conseguimos concluir e o código abaixo ficou perfeito.

    Se alguem precisar está aí:

    Sub csvfile()
    Dim shtSheet As Worksheet
    For Each shtSheet In ActiveWorkbook.Worksheets
        Excel.Sheets(shtSheet.Name).Activate
        Dim fs As Object, a As Object, i As Integer, s As String, t As String, l As String, mn As String
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set a = fs.CreateTextFile("EFD_" + shtSheet.Name + ".txt", True)
        For R = 1 To Range("A65536").End(xlUp).Row
            s = ""
            c = 1
            While Not IsEmpty(Cells(R, c))
                s = s & Cells(R, c) & ""
                c = c + 1
            Wend
            a.writeline s 'write line
        Next R
    Next shtSheet
    End Sub


    FábioNinja

    • Marcado como Resposta FábioNinja quarta-feira, 11 de julho de 2012 14:30
    quarta-feira, 11 de julho de 2012 14:29