Índice
Com os procedimentos a seguir, você pode usar o DAO para recuperar um conjunto de registros de uma pasta de trabalho fechada e ler / gravar dados.
Chame o procedimento assim:
GetWorksheetData "C: \ Foldername \ Filename.xls", "SELECT * FROM [SheetName $]", ThisWorkbook.Worksheets (1) .Range ("A3")
Substitua SheetName pelo nome da planilha da qual deseja recuperar os dados.
Sub GetWorksheetData (strSourceFile As String, strSQL As String, TargetCell As Range) Dim db As DAO.Database, rs As DAO.Recordset, f As Integer, r As Long Se TargetCell for Nothing Then Sair Sub On Error Resume Next Set db = OpenDatabase (strSourceFile, False, True, "Excel 8.0; HDR = Yes;") 'read only' Set db = OpenDatabase (strSourceFile, False, False, "Excel 8.0; HDR = Yes;") 'write' Set db = OpenDatabase ( "C: \ Nome da pasta \ Nome do arquivo.xls", Falso, Verdadeiro, _ "Excel 8.0; HDR = Sim;") 'somente leitura' Definir db = OpenDatabase ("C: \ Nome da pasta \ Nome do arquivo.xls", Falso, Falso, _ "Excel 8.0; HDR = Sim;") 'write On Error GoTo 0 If db Is Nothing Then MsgBox "Não foi possível encontrar o arquivo!", VbExclamation, ThisWorkbook.Name Exit Sub End If' 'list worksheet names' For f = 0 Para db.TableDefs.Count - 1 'Debug.Print db.TableDefs (f) .Name' Next f 'abre um conjunto de registros em erro Resume Next Set rs = db.OpenRecordset (strSQL)' Set rs = db.OpenRecordset ( "SELECT * FROM [SheetName $]") 'Set rs = db.OpenRecordset ("SELECT * FROM [SheetName $]" & _ "WHERE [Field Name] LIKE 'A *'") 'Set rs = db.OpenRecordset ("SELECT * FROM [SheetName $]" & _ "WHERE [Field Name] LIKE' A * 'ORDER BY [Field Name]" ) On Error GoTo 0 If rs Is Nothing Then MsgBox "Não é possível abrir o arquivo!", VbExclamation, ThisWorkbook.Name db.Close Set db = Nothing Exit Sub End If RS2WS rs, TargetCell rs.Close Set rs = Nothing db. Fechar Definir db = Nothing End Sub Sub RS2WS (rs As DAO.Recordset, TargetCell As Range) Dim f As Integer, r As Long, c As Long Se rs Is Nothing Then Sair Sub If TargetCell Is Nothing Then Sair Sub With Application .Calculation = xlCalculationManual .ScreenUpdating = False .StatusBar = "Gravando dados do conjunto de registros …" End With With TargetCell.Cells (1, 1) r = .Row c = .Column End With With TargetCell.Parent .Range (.Cells (r, c ), .Cells (.Rows.Count, c + rs.Fields.Count - 1)). Limpar 'limpar conteúdo existente' escrever cabeçalhos de coluna Para f = 0 Para rs.Fields.Count - 1 Em erro, continuar próximo .Cells ( r, c + f) .Formula = rs.Fields (f) .Nome On Error GoTo 0 Next f 'write rec ords On Error Resume Next rs.MoveFirst On Error GoTo 0 Do While Not rs.EOF r = r + 1 For f = 0 To rs.Fields.Count - 1 On Error Resume Next .Cells (r, c + f) .Formula = rs.Fields (f) .Value On Error GoTo 0 Next f rs.MoveNext Loop .Rows (TargetCell.Cells (1, 1) .Row) .Font.Bold = True .Columns ("A: IV"). AutoAjuste End With With Application .StatusBar = False .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub
Os exemplos de macro pressupõem que seu projeto VBA adicionou uma referência à biblioteca de objetos DAO.
Você pode fazer isso de dentro do VBE selecionando o menu Tools, References e selecionando Microsoft DAO x.xx Object Library.
