擷取SQL Server資料到Excel工作表上

Private Sub CommandButton1_Click()
Worksheets("工作表1").Select '清除工作表1資料
  Cells.Select
   Selection.Delete Shift:=xlUP
   Range("A1").Select

Dim cnnConnect As Object
Dim rstRecordset As Object
  Columns("A:C").Select
  Range("A1").Activate
  Selection.Delete Shift:=xlToLeft
set cnnConnect = CreateObject("ADODB.connection")
set rstRecordset = CreateObject("ADODB.Recordset")

cnnConnect.Open "Provider=SQLOLEDB;" & _  '建立資料庫連結
  "Data Source = DBS\sql_server;" & _
  "User ID=XXXX;Password=XXXX;"

rstRecordset.Open _
   Source:="select item,serial,dat from XXX-database", _
   ActiveConnection:=cnnConnect


With ActiveSheet.QueryTables.Add( _
    Connection:=rstRecordset, _
    Destination:=Range("A1"))
.Name = "Contact List"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False

End With

Range("A1").Value = "項次"
Range("B1").Value = "序號"
Range("C1").Value = "日期時間"

ActiveWorkbook.Worksheets("工作表1").QueryTables(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets("工作表1").QueryTables(1).Sort.SortFields.Add Key:= _
Range("A2:A500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal

With ActiveWorkbook.Worksheets("工作表1").QueryTables(1).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

MsgBox "OK"

End Sub