- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2013-6-8 15:21
| 只看該作者
回復 1# torrent - Option Explicit
- Sub Ex()
- Dim I As Integer, Rng As Range
- With ActiveSheet '工作表中 [A欄] 有事業編號
- Set Rng = .[A2] '從A2開始讀取
- Application.DisplayAlerts = False '關閉應用程式的詢問
- Do While Rng <> "" '直到A欄沒資料
- With Workbooks.Add(1) '新增活頁簿
- With .Sheets(1).QueryTables.Add(Connection:="URL;http://prtr.epa.gov.tw/resultEMS.aspx?emsno=" & Rng & "&tab=Panel1", _
- Destination:=[A1]) '工作表新增,匯入外部查詢.
- .WebSelectionType = xlSpecifiedTables
- .WebFormatting = xlWebFormattingNone
- .WebTables = "6,""GridView3"""
- .WebPreFormattedTextToColumns = True
- .WebConsecutiveDelimitersAsOne = True
- .WebSingleBlockTextImport = False
- .WebDisableDateRecognition = False
- .WebDisableRedirections = False
- .Refresh BackgroundQuery:=False
- .Parent.Names(.Name).Delete
- .Delete
- End With
- .SaveAs ThisWorkbook.Path & "\" & Rng '存檔資料夾名稱
- ' .Close '關閉檔案
- End With
- Set Rng = Rng.Offset(1) '下移一列
- Loop
- Application.DisplayAlerts = True '恢復應用程式的詢問
- End With
- End Sub
|
|
發表於 2013-6-7 12:30
| 
