none
Leitura de Planilhas RRS feed

  • Pergunta

  • Pessoal,

    Estou precisando criar uma aplicação que lera vários documentos(.xls) dentro de uma pasta.
    Todos esses documentos serão iguais apenas com o nome diferente.

    Como eu consigo fazer uma rotina que leia todos estes docs e unam eles dentro de um novo doc(.xls)?



    Leonardo Ruiz
    quinta-feira, 25 de junho de 2009 14:50

Respostas

  • Dá uma olhada no código abaixo para ter uma idéia de como fazer.
    No exemplo, leio as planilhas de uma pasta e gravo numa tabela do Access.

    abs!



    Sub Consolida()
    On Error GoTo erro_consolida
       
           
        Set xl_Excel = New Excel.Application
        Set rst = New ADODB.Recordset
       
        rst.Open "CONSOLIDADO", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
       
        xl_pasta = Dir(CurrentProject.Path & "\*.xls")
       
        Do While xl_pasta <> ""
            DoEvents
            xl_Excel.Workbooks.Open CurrentProject.Path & "\" & xl_pasta
            linha = 2
           
            With xl_Excel.ActiveSheet
                Do Until Trim(cells(linha, 2).Value) = ""
                    rst.AddNew
                    rst.Fields(0) = cells(linha, 1)
                    rst.Fields(1) = cells(linha, 2)
                    rst.Fields(2) = cells(linha, 3)
                    rst.Fields(3) = cells(linha, 4)
                    rst.Fields(4) = cells(linha, 5)
                    rst.Fields(5) = cells(linha, 6)
                    rst.Fields(6) = cells(linha, 7)
                    rst.Fields(7) = cells(linha, 8)
                    rst.Fields(8) = cells(linha, 9)
                    rst.Fields(9) = cells(linha, 10)
                    rst.Fields(10) = cells(linha, 11)
                    rst.Fields(11) = cells(linha, 12)
                    rst.Update
                    linha = linha + 1
                Loop
           
            End With
                   
            xl_Excel.ActiveWorkbook.Close (True)
            xl_pasta = Dir
       
        Loop

        xl_Excel.Quit
        Set xl_Excel = Nothing
       
        rst.Close
        Set rst = Nothing
       
        Exit Sub
    End sub

    sexta-feira, 3 de julho de 2009 16:46
  • Cara eu resolvi o meu problema com este código



        Application.Calculation = xlCalculationManual
        Application.DisplayAlerts = False
        Dim ws  As Worksheet
        Dim wb  As Workbook
        Dim wsNome As String
        Dim docNome As String
        Set wb = ActiveWorkbook
        Workbooks.Open Filename:="C:\Apontamentos.xls"
        Sheets(mes).Select
        Range("A3:E3").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.ClearContents
        Workbooks("Apontamentos.xls").Close SaveChanges:=True
        Arquivos = Dir$("C:\Usuarios\*.xls")
        Workbooks.Open Filename:="C:\Apontamentos.xls"
        While Arquivos <> ""
        Workbooks.Open Filename:=("C:\Usuarios\" & Arquivos)
        docNome = Arquivos
        Windows(docNome).Activate
        Arquivos = Dir$
            wsNome = "Apontamentos"
            If wsNome = "Apontamentos" Then
                Sheets("" & wsNome).Select
                Range("A3:E3").Select
                Range(Selection, Selection.End(xlDown)).Select
                Selection.Copy
                Windows("Apontamentos.xls").Activate
                Sheets(mes).Select
                livre = Worksheets(mes).UsedRange.Rows.Count
                Range("A" & livre + 1).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                Application.CutCopyMode = False
                Workbooks(docNome).Close SaveChanges:=False
             End If
        Wend
        Workbooks("Apontamentos.xls").Close SaveChanges:=True
        Application.Calculation = xlCalculationAutomatic
        Application.DisplayAlerts = False

    Mas valeu de qualquer maneira :D
    Leonardo Ruiz
    sexta-feira, 3 de julho de 2009 17:42

Todas as Respostas

  • Dá uma olhada no código abaixo para ter uma idéia de como fazer.
    No exemplo, leio as planilhas de uma pasta e gravo numa tabela do Access.

    abs!



    Sub Consolida()
    On Error GoTo erro_consolida
       
           
        Set xl_Excel = New Excel.Application
        Set rst = New ADODB.Recordset
       
        rst.Open "CONSOLIDADO", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
       
        xl_pasta = Dir(CurrentProject.Path & "\*.xls")
       
        Do While xl_pasta <> ""
            DoEvents
            xl_Excel.Workbooks.Open CurrentProject.Path & "\" & xl_pasta
            linha = 2
           
            With xl_Excel.ActiveSheet
                Do Until Trim(cells(linha, 2).Value) = ""
                    rst.AddNew
                    rst.Fields(0) = cells(linha, 1)
                    rst.Fields(1) = cells(linha, 2)
                    rst.Fields(2) = cells(linha, 3)
                    rst.Fields(3) = cells(linha, 4)
                    rst.Fields(4) = cells(linha, 5)
                    rst.Fields(5) = cells(linha, 6)
                    rst.Fields(6) = cells(linha, 7)
                    rst.Fields(7) = cells(linha, 8)
                    rst.Fields(8) = cells(linha, 9)
                    rst.Fields(9) = cells(linha, 10)
                    rst.Fields(10) = cells(linha, 11)
                    rst.Fields(11) = cells(linha, 12)
                    rst.Update
                    linha = linha + 1
                Loop
           
            End With
                   
            xl_Excel.ActiveWorkbook.Close (True)
            xl_pasta = Dir
       
        Loop

        xl_Excel.Quit
        Set xl_Excel = Nothing
       
        rst.Close
        Set rst = Nothing
       
        Exit Sub
    End sub

    sexta-feira, 3 de julho de 2009 16:46
  • Cara eu resolvi o meu problema com este código



        Application.Calculation = xlCalculationManual
        Application.DisplayAlerts = False
        Dim ws  As Worksheet
        Dim wb  As Workbook
        Dim wsNome As String
        Dim docNome As String
        Set wb = ActiveWorkbook
        Workbooks.Open Filename:="C:\Apontamentos.xls"
        Sheets(mes).Select
        Range("A3:E3").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.ClearContents
        Workbooks("Apontamentos.xls").Close SaveChanges:=True
        Arquivos = Dir$("C:\Usuarios\*.xls")
        Workbooks.Open Filename:="C:\Apontamentos.xls"
        While Arquivos <> ""
        Workbooks.Open Filename:=("C:\Usuarios\" & Arquivos)
        docNome = Arquivos
        Windows(docNome).Activate
        Arquivos = Dir$
            wsNome = "Apontamentos"
            If wsNome = "Apontamentos" Then
                Sheets("" & wsNome).Select
                Range("A3:E3").Select
                Range(Selection, Selection.End(xlDown)).Select
                Selection.Copy
                Windows("Apontamentos.xls").Activate
                Sheets(mes).Select
                livre = Worksheets(mes).UsedRange.Rows.Count
                Range("A" & livre + 1).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                Application.CutCopyMode = False
                Workbooks(docNome).Close SaveChanges:=False
             End If
        Wend
        Workbooks("Apontamentos.xls").Close SaveChanges:=True
        Application.Calculation = xlCalculationAutomatic
        Application.DisplayAlerts = False

    Mas valeu de qualquer maneira :D
    Leonardo Ruiz
    sexta-feira, 3 de julho de 2009 17:42