擷取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

不動產買賣查詢-Excel VBA

Excel VBA是一個很好用的程式設計工具,它的物件不外乎就是Application;Workbooks,Sheets 及Chart,利用巨集的方式執行副程式來達成數據的收集,篩選,分析等功能.這次是利用內政部不動產交易實價查詢服務網http://lvr.land.moi.gov.tw/來做"類大數據"分析的練習.

Sub selects()
 x = InputBox("請輸入關鍵字!!")
    For i = 2 To Sheets.Count '防止查詢已存在的名稱而產生錯誤
        If x = Sheets(i).Name Then
            MsgBox "工作表已存在請先刪除!!"
            Exit Sub
            'Application.DisplayAlerts = False '或者自動覆蓋更新
            'Sheets(i).Delete
            'Application.DisplayAlerts = True
            Exit For
        End If
    Next

    If x = "" Then '無填入訊息警示
        MsgBox "請務必輸入資料!!"
        Exit Sub
    End If

    Range("C1").Select '游標放C1

    selection.AutoFilter  '篩選
    r = Range("A1").End(xlDown).Row
    ActiveSheet.Range("$A$1:$L$" & r).AutoFilter Field:=3, Criteria1:="=*" & x & "*"

    If Range("A1").End(xlDown).Row = 65536 Then   '無結果
        MsgBox "查無資料!!"
        selection.AutoFilter
        Exit Sub
    End If

    Range("A1").Select  '複製
    Range(selection, selection.End(xlToRight)).Select
    Range(selection, selection.End(xlDown)).Select
    selection.Copy

    Sheets.Add After:=Sheets(Sheets.Count)  '新增工作表
    Sheets(Sheets.Count).Name = x

    Range("A1").Select  '貼上
    ActiveSheet.Paste

    selection.Columns.AutoFit  '自動調整欄寬

    Range("A1").Select

    Sheets(1).Select  '切回原工作表
    Application.CutCopyMode = False

    selection.AutoFilter '取消
    Range("A1").Select

End Sub

接著可到服務網去下載 lvr_landxls.zip套用測試了