Met onderstaande procedures kun je DAO gebruiken om een recordset uit een gesloten werkmap op te halen en data te lezen/schrijven.
Roep de procedure als volgt aan:
GetWorksheetData "C:\Foldername\Filename.xls", "SELECT * FROM [SheetName$]", ThisWorkbook.Worksheets(1).Range("A3")
Vervang Bladnaam door de werkbladnaam waarvan u gegevens wilt ophalen.
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 Als TargetCell Niets is, sluit dan Sub af bij fout Hervat volgende set db = OpenDatabase (strSourceFile, False, True, "Excel 8.0;HDR=Yes;") ' alleen-lezen 'Set db = OpenDatabase(strSourceFile, False, False, "Excel 8.0;HDR=Yes;")' schrijven 'Set db = OpenDatabase( "C:\Foldername\Filename.xls", False, True, _ "Excel 8.0;HDR=Yes;") ' alleen-lezen 'Set db = OpenDatabase("C:\Foldername\Filename.xls", False, False, _ "Excel 8.0;HDR=Ja;") ' schrijf bij fout Ga naar 0 Als db niets is, dan MsgBox "Kan het bestand niet vinden!", vbExclamation, ThisWorkbook.Name Exit Sub End If '' lijst werkbladnamen ' For f = 0 Naar db.TableDefs.Count - 1 ' Debug.Print db.TableDefs(f).Name 'Volgende f' open een recordset Bij fout Hervatten volgende 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]" ) Bij fout Ga naar 0 Als rs niets is, dan MsgBox "Kan het bestand niet openen!", vbExclamation, ThisWorkbook.Name db.Close Set db = Nothing Exit Sub End If RS2WS rs, TargetCell rs.Close Set rs = Nothing db. Sluiten Stel db = Niets in Beëindig sub Sub RS2WS (rs As DAO.Recordset, TargetCell As Range) Dim f As Integer, r As Long, c As Long Als rs niets is, sluit dan Sub af Als TargetCell niets is, sluit dan Sub af met toepassing. Berekening = xlCalculationManual .ScreenUpdating = False .StatusBar = "Writing data from recordset… " 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)).Clear 'clear bestaande inhoud' schrijf kolomkoppen For f = 0 To rs.Fields.Count - 1 On Error Resume Next .Cells( r, c + f).Formule = rs.Fields(f).Naam bij fout Ga naar 0 Volgende f ' schrijf 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 Hervat volgende .Cells(r, c + f).Formule = rs.Fields(f).Value On Error GoTo 0 Next fr rs.MoveNext Loop .Rows(TargetCell.Cells(1, 1).Row).Font.Bold = True .Columns("A:IV").AutoFit Eindig met met toepassing .StatusBar = False .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub
De macrovoorbeelden gaan ervan uit dat uw VBA-project een verwijzing naar de DAO-objectbibliotheek heeft toegevoegd.
U kunt dit vanuit de VBE doen door het menu Tools, References te selecteren en Microsoft DAO x.xx Object Library te selecteren.