網頁查詢問題

網頁查詢碰到要輸入關鍵字,在查詢,結果可否用選擇的方式,選擇正確在放入EXCEL表格內呢?

地段.zip (255.18 KB)

樓主熱帖

sillykin

中學生 Rank: 2

帖子: 169
主題: 41
精華: 0
積分: 219
點名: 0
作業系統: WIN10
軟體版本: office 2007
閱讀權限: 20
性別: 男
註冊時間: 2012-7-31
最後登錄: 2026-2-10

2^#

發表於 2020-7-3 19:17 | 顯示全部帖子

Option Explicit
Dim IE As Object, Combo_Ar(), xMsg As Boolean, xButton As Boolean, xRng As Range

Private Sub Label6_Click()

End Sub

Private Sub UserForm_Initialize()
'ComboBox 控制項 -> 縣市'事務所名稱 '鄉鎮市區'段'小段
Combo_Ar = Array(ComboBox0, ComboBox1, ComboBox2)
Set IE = CreateObject("InternetExplorer.Application")
Set xRng = [B36 ]
' Label1 = ""
xRng.Resize(, ６) = ""
With IE
      '.Visible = True '可不顯示IE
      .Navigate "http://lisp.land.moi.gov.tw/MMS/MMSpage.aspx#gobox03"
      Do While .Busy Or .readyState <> 4: DoEvents: Loop
      ComboBox_list 0
End With
End Sub
Private Sub ComboBox_list(ByVal Op As Integer)
'縣市'事務所名稱 '鄉鎮市區'段'小段的選項內容導入ComboBox的list
Dim xSelect As Object, i As Integer, x As Integer
xMsg = True
'xButton = True
For i = Op To UBound(Combo_Ar)
      With Combo_Ar(i)
         If i = Op And .ListCount = 0 Then
            Do
                  Set xSelect = IE.Document.all.tags("SELECT")(i)
            Loop Until xSelect.Length > 0
            ' MsgBox .List(1)
            For x = 0 To xSelect.Length - 1
                  .AddItem
                  .List(.ListCount - 1, 0) = xSelect(x).innertext
            Next
            .ListIndex = 0
         ElseIf i = Op And .ListIndex > 0 Then
            Do
                  Set xSelect = IE.Document.all.tags("SELECT")(i)
            Loop Until xSelect.Length > 0
            xSelect.selectedIndex = .ListIndex
            If Op <> UBound(Combo_Ar) Then
                  xSelect.fireEvent ("onchange")
                  Do While IE.Busy Or IE.readyState <> 4: DoEvents: Loop
                  Do
                     Set xSelect = IE.Document.all.tags("SELECT")(i + 1)
                  Loop Until xSelect.Length > 0
                  With Combo_Ar(i + 1)
                     .Clear
                     For x = 0 To xSelect.Length - 1
                        .AddItem
                        .List(.ListCount - 1, 0) = xSelect(x).innertext
                     Next
                     .ListIndex = 0
                  End With
            End If
         ElseIf i > 0 Then
            If Combo_Ar(i - 1).ListIndex = 0 Or Combo_Ar(i - 1).ListCount = 0 Then
                  .Clear
            End If
         End If
         If .ListCount = 0 Or .ListIndex = 0 Then xButton = False
         If UBound(Combo_Ar) = i And .ListCount > 0 Then
            If .ListCount = 2 And .List(1) = "" Then xButton = True
            If .ListCount = 2 And .List(1) <> "" And .ListIndex > 0 Then xButton = True
            If .ListCount > 2 And .ListIndex > 0 Then xButton = True
         End If
      End With
Next
If xButton Then
      button_Click
Else
      xRng.Cells(1, 6) = ""
      'Label1 = ""
End If
xMsg = False
End Sub
Private Sub ComboBox0_Change()    '縣市
   If xMsg = False Then ComboBox_list 0
   xRng.Cells(1, 2) = ComboBox0.Value
End Sub
Private Sub ComboBox1_Change()    '事務所名稱
If xMsg = False Then ComboBox_list 1
xRng.Cells(1, 3) = ComboBox1.Value
End Sub
Private Sub ComboBox2_Change()    '鄉鎮市區
If xMsg = False Then ComboBox_list 2
xRng.Cells(1, 4) = ComboBox2.Value
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
IE.Quit
End Sub
Private Sub button_Click() '查詢
Dim xIObject As Object, E
With IE
      Do
         Set xIObject = .Document.all.tags("INPUT")
      Loop Until Not xIObject Is Nothing
      For Each E In xIObject
         If E.Value = "查詢" And E.Type = "button" Then
            E.Click
            Exit For
         End If
      Next
      Do While .Busy Or .readyState <> 4: DoEvents: Loop
      Do
         Set xIObject = .Document.all.tags("STRONG")(0)
      Loop Until Not xIObject Is Nothing
End With
E = xIObject.innertext
'Label1 = Split(xIObject.innertext, "：")(1)
xRng.Cells(1, 1) = "'" & Split(xIObject.innertext, "：")(1)
Label8 = Split(xIObject.innertext, "：")(1)
End Sub
目前只能抓到第一個值,但第二、三個值抓不到，不知那位大大能幫忙，感恩

TOP

sillykin