實價登錄EXCEL查詢程式 (第2頁)

kasimu
個人積分：96分
文章編號：64083032

96分

樓主

2017-04-20 15:43

savage500 wrote:
沒是我看完VBA了...(恕刪)

舉例如下,要多少季的資料頁都可以加,舉例多加一季,放在Sheet7

'新增Sheet7

'--------在資料庫中將搜尋到的資料標上黃底色
If InStr(Sheet5.Cells(i, "C"), Sheet6.Cells(4, 1)) Then
Sheet5.Rows(i).Interior.Color = RGB(255, 255, 0)

If InStr(Sheet7.Cells(i, "C"), Sheet6.Cells(4, 1)) Then
Sheet5.Rows(i).Interior.Color = RGB(255, 255, 0)

'---------資料庫中搜尋關鍵字---------

'新增Sheet7

'Sheet7中搜尋資料
If InStr(Sheet5.Cells(i, "C"), Sheet6.Cells(4, 1)) Then

For kk = 1 To 30
Sheet23.Cells(j, kk) = Sheet5.Cells(i, kk)

Next

j = j + 1
End If

'--------------清除關鍵字上色

'新增Sheet7
Sheet7.Select
ActiveSheet.Range("A1:AA5000").Select
Selection.Interior.ColorIndex = xlNone

snare

snare
個人積分：3046分
文章編號：64088812

3046分

12樓

2017-04-21 0:21

把3個按鍵合併成1個，會比較方便
因為按下搜尋就代表要清除舊搜尋資料、清除舊上色資料
上色也不必獨立出來，搜尋的時候順便上色就好
沒必要分成3個步驟

所以幫您把除了排版、美觀、字型之外的那100多行的主要功能程式碼
合併成一個按鈕，順便優化程式碼，減少到23行，讓速度快一點
這樣想增加工作表，就不用再改程式碼了

Sub findtest()

t = Timer
Application.DisplayAlerts = False
target = 2
Sheets("查詢結果").Cells.ClearContents

For i = 1 To Worksheets.Count

If Not (Worksheets(i).Name = "查詢結果" Or Worksheets(i).Name = "搜尋頁") Then
Worksheets(i).Cells.Interior.ColorIndex = xlNone
With Sheets(Worksheets(i).Name)
If target = 2 Then
.Rows(1).Copy Sheets("查詢結果").Rows(1)
End If
lastrow = .Range("a1").CurrentRegion.Rows.Count

For j = 1 To lastrow
If InStr(.Cells(j, 3), Sheets("搜尋頁").Cells(4, 1)) Then
.Rows(j).Copy Sheets("查詢結果").Rows(target)
.Rows(j).Interior.Color = RGB(255, 255, 0)
target = target + 1
End If
Next

End With
End If
Next

Application.DisplayAlerts = True
Sheets("查詢結果").Select
Debug.Print Timer - t

End Sub

剩下"查詢結果工作表"的排版、美觀、字型，請自行補上

kasimu

kasimu
個人積分：96分
文章編號：64092628

96分

樓主

2017-04-21 11:04

snare wrote:
把3個按鍵合併成1...(恕刪)

測試了一下很不錯
研究研究程式碼
感謝

之後想我還想作成直接載入政府的資料庫
這樣就不用分各個地區
大家可以下載好政府的實價登錄資料EXCEL,放到資料夾內
一鍵載入想要查詢的區域跟季數
就不用分這麼多個區域的EXCEL給大家下載

jrming

jrming
個人積分：15分
文章編號：64093506

15分

14樓

2017-04-21 12:00

kasimu wrote:
測試了一下很不錯研...(恕刪)

感謝兩位提供如此方便的查詢方式

100分

chumini

chumini
個人積分：16分
文章編號：64093852

16分

15樓

2017-04-21 12:26

你好，請問有沒有台中的分享呢？謝謝

kasimu

kasimu
個人積分：96分
文章編號：64094757

96分

樓主

2017-04-21 13:31

chumini wrote:
你好，請問有沒有台...(恕刪)

晚一點在放上來

jrming

jrming
個人積分：15分
文章編號：64095637

15分

17樓

2017-04-21 14:37

kasimu wrote:
晚一點在放上來

把東西組合一下.....

Sub findtest()

t = Timer
Application.DisplayAlerts = False
target = 2
Sheets("查詢結果").Cells.ClearContents

For i = 1 To Worksheets.Count

If Not (Worksheets(i).Name = "查詢結果" Or Worksheets(i).Name = "搜尋頁") Then
Worksheets(i).Cells.Interior.ColorIndex = xlNone
With Sheets(Worksheets(i).Name)
If target = 2 Then
.Rows(1).Copy Sheets("查詢結果").Rows(1)
End If
lastrow = .Range("a1").CurrentRegion.Rows.Count

For j = 1 To lastrow
If InStr(.Cells(j, 3), Sheets("搜尋頁").Cells(4, 1)) Then
.Rows(j).Copy Sheets("查詢結果").Rows(target)
.Rows(j).Interior.Color = RGB(255, 255, 0)
target = target + 1
End If
Next

End With
End If
Next

Application.DisplayAlerts = True
Sheets("查詢結果").Select

'字型調整

ActiveSheet.Range("A1:AB5000").Select
With Selection.Font
.Name = "微軟正黑體"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "微軟正黑體"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True

'排列欄位

ActiveSheet.Range("E1:G5000").Select
Selection.Cut
ActiveSheet.Range("AF1:AH5000").Select
ActiveSheet.Paste
ActiveSheet.Range("F1:G5000").Select
Selection.Insert Shift:=xlToRight
ActiveSheet.Range("X:AB").Select
Selection.Cut
ActiveSheet.Range("E1:I5000").Select
ActiveSheet.Paste
ActiveSheet.Range("AH:AJ").Select
Selection.Cut
ActiveSheet.Range("X1").Select
ActiveSheet.Paste
ActiveSheet.Range("AA:AB").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range("AB1:AB5000").Select
Selection.Delete Shift:=xlToLeft

'依照日期排序

Range("A1:AB195").Sort Key1:=Range("J2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke, DataOption1:=xlSortNormal
ActiveSheet.Range("A1").Select
Debug.Print Timer - t

MsgBox "資料查詢完成."

End Sub

dmkillerone

dmkillerone
個人積分：41分
文章編號：64100482

41分

18樓

2017-04-21 21:55

樓主您好，不知竹北的有無機會放上，感謝您

kasimu

kasimu
個人積分：96分
文章編號：64111544

96分

樓主

2017-04-23 2:00

dmkillerone wrote:
樓主您好，不知竹北...(恕刪)

新竹區的也是可以做拉
其實更新這個很簡單,晚點做個教學
大家可以做自己的縣市

如果自動載入資料的VBA寫好就可以不用手動更新了

kasimu

kasimu
個人積分：96分
文章編號：72976715

96分

樓主

2019-04-30 0:18

更新:2019/04/30
剛好同事有買屋，有更新了一版桃園市的實價資料
下載連結
下載