- 帖子
- 133
- 主題
- 9
- 精華
- 0
- 積分
- 147
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2010
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 高雄
- 註冊時間
- 2010-5-1
- 最後登錄
- 2024-11-11
|
底下紅色字體是我增加的,其餘我是copy你的程式沒做修改
Sub 巨集2()
On Error Resume Next '表示當一個執行階段錯誤產生時，程式控制立刻到發生錯誤陳述式接下去的陳述式，而繼續執行下去
Dim myrng As Range
Dim myhyps As Hyperlinks
Dim myhyp As Hyperlink
Dim j As Integer
Dim k As Integer
'從網頁擷取資料
For n = 1 To 1
Sheets("擷取資料").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
'取出網頁路徑
Set myrng = Sheets("選手網址").Cells(n + 1, 1)
With myrng
Set myhyps = .Hyperlinks
Set myhyp = myhyps(1)
End With
'myhyp.Address變數可以直接用網址取代
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & myhyp.Address _
, Destination:=Range("$A$1"))
.Name = "Novak-Djokovic_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
j = Cells.Find("Prize Money", lookat:=xlPart).Row '找 Prize Money 列位
MsgBox Cells(j + 1, 6) '如果資料固定在第六欄,就只需要上面那行和此行程式
'k = Cells(j + 1, 256).End(xlToLeft).Column '在Prize Money下一列,回傳最後一欄...如果資料不固定在第六欄,才需要改為此行程式
Next n
End Sub |
|
發表於 2014-11-17 14:09
| 
