- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
11#
發表於 2016-2-26 14:54
| 只看該作者
本帖最後由 GBKEE 於 2016-3-4 14:19 編輯
回復 9# yehmengfeng
試試看
UserForm 模組的程式碼
UserForm 需制定控制項 CommandButton1,ComboBox1,ComboBox2- Option Explicit
- Dim Sh(1 To 2) As Worksheet
- Private Sub UserForm_Initialize()
- Set Sh(1) = Sheets.Add '設定新增工作表
- Sh(1).Visible = False '隱藏工作表
- 觀測查詢_設定
- End Sub
- Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
- Application.DisplayAlerts = False
- Sh(1).Delete
- Application.DisplayAlerts = True
- End Sub
- Private Sub 觀測查詢_設定()
- Dim Url As String, i As Double, op As Object, xDate As Date
- Dim oHtmldoc As Object
- Set oHtmldoc = CreateObject("htmlfile")
- Url = "http://e-service.cwb.gov.tw/HistoryDataQuery/QueryDataController.do?command=viewMain" '
- With CreateObject("msxml2.xmlhttp")
- .Open "Get", Url, False
- .Send
- oHtmldoc.write .responseText
- End With
- With ComboBox1
- For Each op In oHtmldoc.all.tags("SELECT")(0)
- .AddItem
- .List(.ListCount - 1, 0) = op.innertext '測站:名稱
- .List(.ListCount - 1, 1) = op.Value '測站:數值
- Next
- .ListIndex = 0
- End With
- With ComboBox2
- For i = 0 To -59 Step -1 '60個月份
- xDate = DateAdd("M", i, Date)
- .AddItem
- .List(.ListCount - 1, 0) = Format(xDate, "EE年MM月")
- .List(.ListCount - 1, 1) = DateSerial(Year(xDate), Month(xDate), 1)
- Next
- .ListIndex = 0
- End With
- End Sub
- Private Sub CommandButton1_Click() '按紐(資料查詢)
- Dim surl As String, QT As Range, Qdate As Date, Station As String, Msg As Boolean
- 'http://e-service.cwb.gov.tw/HistoryDataQuery/DayDataController.do?
- surl = "URL;http://e-service.cwb.gov.tw/HistoryDataQuery/DayDataController.do?"
- surl = surl & "command=viewMain&station=" & ComboBox1.List(ComboBox1.ListIndex, 1)
- Station = ComboBox1.List(ComboBox1.ListIndex, 0) & "(" & ComboBox1.List(ComboBox1.ListIndex, 1) & ")" '工作表名稱
- On Error GoTo Make_station: '處裡錯誤: 測站不存在
- Set Sh(2) = Sheets(Station) '指定工作表(測站)
- On Error GoTo 0 '有錯誤不處理了
- Application.ScreenUpdating = False
- For Qdate = ComboBox2.List(ComboBox2.ListIndex, 1) To DateAdd("m", 1, ComboBox2.List(ComboBox2.ListIndex, 1)) - 1
- surl = "URL;http://e-service.cwb.gov.tw/HistoryDataQuery/DayDataController.do?command=viewMain&station=" & ComboBox1.List(ComboBox1.ListIndex, 1) & "&datepicker=" & Format(Qdate, "yyyy-m-dd")
- If Qdate > Date Then Exit For '日期大於當日
- If Not Sh(2).Range("A:A").Find(Qdate, LookIn:=xlFormulas) Is Nothing Then GoTo Ne '日期資料已存在,下一日期迴圈
- Application.StatusBar = "匯入 " & Qdate & " 資料..." '狀態列的文字
- With Sh(1)
- .UsedRange.Delete
- With .QueryTables.Add(Connection:=surl, Destination:=.Range("$A$1"))
- .WebTables = "MyTable"
- .WebFormatting = xlWebFormattingNone
- .Refresh BackgroundQuery:=False
- If .ResultRange.Rows.Count > 5 Then '有資料
- Set QT = .ResultRange '含表頭的資料範圍
- With Sh(2)
- If .UsedRange.Count = 1 Then '工作表(測站)為空白
- .Range("A1") = "觀測時間"
- .Range("A1").Resize(5).Merge
- Else
- Set QT = QT.Rows("6:" & QT.Rows.Count) '不含表頭的資料
- End If
- With .Cells(Rows.Count, "b").End(xlUp)
- If .Row = 1 Then '工作表(測站)為空白
- QT.Copy .Cells
- Else '.Row = 4 ->沒有資料但有表頭
- QT.Copy .Cells(IIf(.Row = 4, 3, 2))
- End If
- End With
- With .Range(.Cells(Rows.Count, "A").End(xlUp).Offset(1).Address & ":A" & Sh(2).Cells(Rows.Count, "B").End(xlUp).Row)
- .Cells = Qdate 'A欄寫上日期
- .NumberFormatLocal = "yyyy-mm-dd" '給予格式
- End With
- End With
- End If
- .Delete
- End With
- End With
- Ne:
- Next
- Application.StatusBar = False
- Application.ScreenUpdating = True
- '排序
- With Sh(2).UsedRange.Offset(5)
- .Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1"), Order2:=xlAscending, Header:=xlNo
- End With
- Exit Sub
- Make_station:
- Sheets.Add(Sheet1).Name = Station '新增工作表(測站)
- Resume '回到錯誤的程式碼繼續程式
- End Sub
|
|
發表於 2016-1-7 10:09
| 
