Innehållsförteckning
Med procedurerna nedan kan du använda DAO för att hämta en postuppsättning från en stängd arbetsbok och läsa/skriva data.
Ring proceduren så här:
GetWorksheetData "C: \ Foldername \ Filename.xls", "SELECT * FROM [SheetName $]", ThisWorkbook.Worksheets (1) .Range ("A3")
Ersätt SheetName med kalkylbladets namn som du vill hämta data från.
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 TargetCell is Nothing Then Exit 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: \ Foldername \ Filename.xls", False, True, _ "Excel 8.0; HDR = Yes;") 'read only' Set db = OpenDatabase ("C: \ Foldername \ Filename.xls", False, False, _ "Excel 8.0; HDR = Ja;") 'skriv på fel GoTo 0 Om db är ingenting då kan MsgBox "Kan inte hitta filen!", VbExclamation, ThisWorkbook.Name Avsluta Sub End Om' 'lista kalkylblad namn' För f = 0 To db.TableDefs.Count - 1 'Debug.Print db.TableDefs (f) .Name' Next f 'open a recordset On Error 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]" ) Vid fel GoTo 0 Om rs är ingenting Då kan MsgBox "Kan inte öppna filen!", VbExclamation, ThisWorkbook.Name db.Close Set db = Nothing Exit Sub End If RS2WS rs, TargetCell rs.Close Set rs = Nothing db. Stäng Set db = Nothing End Sub Sub RS2WS (rs As DAO.Recordset, TargetCell As Range) Dim f As Integer, r As Long, c As Long If rs Nothing Then Exit Sub If TargetCell Is Nothing Then Exit Sub With Application .Calculation = xlCalculationManual .ScreenUpdating = False .StatusBar = "Skriva data från rekordmängd …" Avsluta med TargetCell.Cells (1, 1) r = .Rad c = .Column Avsluta med TargetCell.Parent .Range (.Cells (r, c) ), .Cells (.Rows.Count, c + rs.Fields.Count - 1)). Rensa "rensa befintligt innehåll" skriva kolumnrubriker För f = 0 Till rs.Fields.Count - 1 Vid fel Återuppta nästa. Celler ( r, c + f) .Formula = rs.Fields (f) .Name On Error GoTo 0 Nästa f 'skriv rec ord på fel Återuppta nästa rs.MoveFirst Vid fel 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"). AutoFit Avsluta med applikation .StatusBar = Falskt. Beräkning = xlCalculationAutomatic .ScreenUpdating = Sann slut med slutsub
Makroexemplen förutsätter att ditt VBA -projekt har lagt till en referens till DAO -objektbiblioteket.
Du kan göra detta från VBE genom att välja menyn Verktyg, Referenser och välja Microsoft DAO x.xx Object Library.
