一、簡易查詢系統:

01_下載內政部實價登錄開放資料

02_下載EXCEL檔案

03_只下載新北市開放資料

04_留下不動產買賣資料

05_貼上查詢VBA程式做修改

06_產生輸入地址關鍵字介面

07_自動新增工作表並輸出結果

流程:

利用上周的篩選業務來修改

程式碼:

Sub 篩選地址()

    X = InputBox("請輸入地址關鍵字!!")

    '1.游標放B1

    Range("B1").Select

    '2.篩選

    Selection.AutoFilter

    r = Range("A1").End(xlDown).Row

    ActiveSheet.Range("$A$1:$L$" & r).AutoFilter Field:=3, Criteria1:="=*" & X & "*"

    '3.複製

    Range("A1").Select

    Range(Selection, Selection.End(xlToRight)).Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy

    '4.新增工作表

    Sheets.Add After:=Sheets(Sheets.Count)

    Sheets(Sheets.Count).Name = X

    '5.貼上

    Range("A1").Select

    ActiveSheet.Paste

    '6.自動調整欄寬

    Selection.Columns.AutoFit

   

    Range("A1").Select

    '7.切回原工作表

    Sheets(1).Select

    '8.取消篩選

    Selection.AutoFilter

    '9.切回到A1

    Range("A1").Select

End Sub

**加上防呆功能程式

Sub 篩選地址()

    Sheets(1).Select

    x = InputBox("請輸入地址關鍵字!!")

   

    '防呆1:如何防止查詢已存在的名稱而產生錯誤

    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

   

    '防呆2:無填寫

    If x = "" Then

        MsgBox "請務必輸入資料!!"

        Exit Sub

    End If

   

    '1.游標放B1

    Range("C1").Select

    '2.篩選

    Selection.AutoFilter

    r = Range("A1").End(xlDown).Row

    ActiveSheet.Range("$A$1:$L$" & r).AutoFilter Field:=3, Criteria1:="=*" & x & "*"

   

    '防呆3:無結果

    If Range("A1").End(xlDown).Row = 65536 Then

        MsgBox "查無資料!!"

        Selection.AutoFilter

        Exit Sub

    End If

   

    '3.複製

    Range("A1").Select

    Range(Selection, Selection.End(xlToRight)).Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy

    '4.新增工作表

    Sheets.Add After:=Sheets(Sheets.Count)

    Sheets(Sheets.Count).Name = x

    '5.貼上

    Range("A1").Select

    ActiveSheet.Paste

    '6.自動調整欄寬

    Selection.Columns.AutoFit

   

    Range("A1").Select

    '7.切回原工作表

    Sheets(1).Select

    Application.CutCopyMode = False

    '8.取消篩選

    Selection.AutoFilter

   

    Range("A1").Select

End Sub

二、批次查詢:

1.建立清單

2.批次查詢_區

3.批次查詢_交易標的

4.批次查詢_每坪單價

5.批次刪除

程式碼:

Sub 批次查詢_區()

    Call 批次刪除

   

    Sheets(1).Select

    For i = 2 To Sheets("清單").Range("A2").End(xlDown).Row

        X = Sheets("清單").Cells(i, "A")

       

        '1.選取J1

        Range("A1").Select

        '2.篩選

        Selection.AutoFilter

        ActiveSheet.Range("$A$1:$K$" & Range("A2").End(xlDown).Row).AutoFilter Field:=1, Criteria1:=X, _

            Operator:=xlAnd

        '3.複製

        Range("A1").Select

        Range(Selection, Selection.End(xlToRight)).Select

        Range(Selection, Selection.End(xlDown)).Select

        Selection.Copy

        '4.新增工作表

        Sheets.Add after:=Sheets(Sheets.Count)

        Sheets(Sheets.Count).Name = X

        '5.貼上

        Range("A1").Select

        ActiveSheet.Paste

        '6.欄寬自動調整

        Columns("A:K").Select

        Selection.Columns.AutoFit

        '7.取消選取

        Range("A1").Select

        Sheets(1).Select

        Application.CutCopyMode = False

        '8.取消篩選

        Selection.AutoFilter

        Range("A1").Select       

    Next

End Sub

Sub 批次查詢_交易標的()

    Call 批次刪除

   

    Sheets(1).Select

    For i = 2 To Sheets("清單").Range("B2").End(xlDown).Row

        X = Sheets("清單").Cells(i, "B")

       

        '1.選取J1

        Range("A1").Select

        '2.篩選

        Selection.AutoFilter

        ActiveSheet.Range("$A$1:$K$" & Range("A2").End(xlDown).Row).AutoFilter Field:=2, Criteria1:=X, _

            Operator:=xlAnd

        '3.複製

        Range("A1").Select

        Range(Selection, Selection.End(xlToRight)).Select

        Range(Selection, Selection.End(xlDown)).Select

        Selection.Copy

        '4.新增工作表

        Sheets.Add after:=Sheets(Sheets.Count)

        Sheets(Sheets.Count).Name = X

        '5.貼上

        Range("A1").Select

        ActiveSheet.Paste

        '6.欄寬自動調整

        Columns("A:K").Select

        Selection.Columns.AutoFit

        '7.取消選取

        Range("A1").Select

        Sheets(1).Select

        Application.CutCopyMode = False

        '8.取消篩選

        Selection.AutoFilter

        Range("A1").Select

       

    Next

End Sub

Sub 批次查詢_每坪單價()

    Call 批次刪除   

    Sheets(1).Select

    For i = 2 To Sheets("清單").Range("C2").End(xlDown).Row

        X = Sheets("清單").Cells(i, "C")

        Y = Sheets("清單").Cells(i, "D")

        '1.選取J1

        Range("A1").Select

        '2.篩選

        Selection.AutoFilter

        ActiveSheet.Range("$A$1:$K$" & Range("A2").End(xlDown).Row).AutoFilter Field:=9, Criteria1:=">" & X, _

            Operator:=xlAnd, Criteria2:="<" & Y

        '3.複製

        Range("A1").Select

        Range(Selection, Selection.End(xlToRight)).Select

        Range(Selection, Selection.End(xlDown)).Select

        Selection.Copy

        '4.新增工作表

        Sheets.Add after:=Sheets(Sheets.Count)

        Sheets(Sheets.Count).Name = X & "-" & Y

        '5.貼上

        Range("A1").Select

        ActiveSheet.Paste

        '6.欄寬自動調整

        Columns("A:K").Select

        Selection.Columns.AutoFit

        '7.取消選取

        Range("A1").Select

        Sheets(1).Select

        Application.CutCopyMode = False

        '8.取消篩選

        Selection.AutoFilter

        Range("A1").Select

       

    Next

End Sub

Sub 批次刪除()

    Application.DisplayAlerts = False

    For i = Sheets.Count To 3 Step -1

        Sheets(i).Delete

    Next

    Application.DisplayAlerts = True

End Sub