- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2012-6-27 21:52
| 只看該作者
回復 1# fusayloveme
匯入104 次 太久了, 找找看哪裡有可以一次匯入的資料.
以下程式試試看- Option Explicit
- Sub Ex()
- Dim xi, q As QueryTable, i As Integer, Rng As Range
- Sheets("紀錄").Cells.Clear '"紀錄" 工作表
- With Sheets("Sheet1") '"Sheet1" 工作表
- .Cells.Clear
- For Each q In .QueryTables
- q.Delete '清除外部查詢
- Next
- With .QueryTables.Add("URL;http://www.l-zzz.com/shiyou/sy_list.jsp?nID=46", .[a1])
- .WebSelectionType = xlSpecifiedTables
- .WebFormatting = xlWebFormattingNone
- .WebTables = "17" '取得頁數
- .WebPreFormattedTextToColumns = True
- .WebConsecutiveDelimitersAsOne = True
- .WebSingleBlockTextImport = False
- .WebDisableDateRecognition = False
- .WebDisableRedirections = False
- .Refresh BackgroundQuery:=False
- End With
- xi = InStr(.[a1], "/") '字串:"共 1859 條紀錄 1/104" 尋找 "/"位置
- xi = Val(Mid(.[a1], xi + 1)) '轉為數字 ' '
- For i = xi To 1 Step -1
- With .QueryTables(1)
- .Connection = "URL;http://www.l-zzz.com/shiyou/sy_list.jsp?nID=46&pageNum=" & i
- .WebSelectionType = xlSpecifiedTables
- .WebFormatting = xlWebFormattingNone
- .WebTables = "16" '資料位置
- .WebPreFormattedTextToColumns = True
- .WebConsecutiveDelimitersAsOne = True
- .WebSingleBlockTextImport = False
- .WebDisableDateRecognition = False
- .WebDisableRedirections = False
- .Refresh BackgroundQuery:=False
- End With
- If i > 1 Then
- Set Rng = .QueryTables(1).ResultRange
- Set Rng = Rng.Range(Rng.Cells(2, 1), Rng.Cells(Rng.Rows.Count, Rng.Columns.Count))
- Rng.Copy '資料複製
- Else
- .QueryTables(1).ResultRange.Copy
- End If
- Sheets("紀錄").[a1].Insert Shift:=xlDown '插入資料
- Next
- End With
- End Sub
複製代碼 |
|