Hi
this is a code I use
'This sub will download the information in the database
'NOTE the worksheet and the database should be in the same folder.
'Otherwise change the path
Sub ObjectInfo()
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim stDB As String, stSQL1 As String
Dim wsBlad1 As Worksheet
Dim rSlutetA As Range, rSlutetR As Range 'My first column is A and my last column is R
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
Set wsBlad1 = ThisWorkbook.Worksheets("Name of sheet")
Application.ScreenUpdating = False
'Path to database Note that the database should be in the same folder as this worksheet
stDB = ThisWorkbook.Path & "\" & "db1.mdb"
'Shows all elevators - objects
stSQL1 = "Select * FROM TableName ORDER BY IdInfo"
'Remove old information
wsBlad1.Range("A1").CurrentRegion.Clear
'Create connection to database and open sql
cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & stDB & ";"
rst.Open stSQL1, cnt
wsBlad1.Select
Set rSlutetA = wsBlad1.Range(Range("A2"), Range("A65536").End(xlUp)) 'Range A2 to the end of column A
Set rSlutetR = wsBlad1.Range(Range("R2"), Range("R65536").End(xlUp)) 'Range R2 to the end of column R
'Write field name
Range("A1").Value = "Column heading"
Range("B1").Value = "Column heading "
Range("C1").Value = "Column heading"
Range("D1").Value = "Column heading"
'Add as many columns as you want and you can skip this if you don't need the headings
Range("A1:R1").Font.FontStyle = "Bold" 'Makes heading bold
'Information copied to worksheet
wsBlad1.Cells(2, 1).CopyFromRecordset rst
'Remove old information, sort and close connection
wsBlad1.Select
'Sorting descending order in column A
Range(rSlutetA, rSlutetR).Sort Key1:=Range("B2"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
cnt.Close
Set cnt = Nothing
ThisWorkbook.Worksheets("Name of sheet").Select
End Sub
You probably have to change it to fit your needs, but I hope it will help you.
Gunilla
Bookmarks