返回列表 上一主題 發帖

[發問] 如何找出網站原始檔網址

回復 1# blue2263
試試看
  1. Option Explicit
  2. Sub 公開資訊網頁()
  3.     Dim A As Object, E As Object
  4.     With CreateObject("InternetExplorer.Application")
  5.         .Visible = True
  6.         ' .Navigate "http://mops.twse.com.tw/mops/web/t164sb04"     '網址:綜合損益表
  7.         .Navigate "http://mops.twse.com.tw/mops/web/stapap1"        '網址:董監事持股餘額明細資
  8.         Do While .ReadyState <> 4 Or .Busy: DoEvents: Loop
  9.             .document.getElementById("isnew").Value = "false"       '選擇: 歷史資料
  10.             '註解上一行程式碼為 -> 選擇: 最新資料,不會執行 If 內程式碼
  11.            
  12.             If .document.getElementById("isnew").Value = "false" Then
  13.              .document.getElementById("isnew").FireEvent ("onchange")
  14.                 .document.getElementById("year").Value = "102"       '年度
  15.                 '.document.getElementById("season").Value = "01"    '綜合損益表:第1季(季別)
  16.                 .document.getElementById("month").Value = "08"      '董監事持股餘額明細資料:月份
  17.             End If
  18.             '********************************************************************
  19.            For Each A In .document.getelementSbyTAGNAME("INPUT")
  20.                 If A.Name = "co_id" Then A.Value = "2303"            '股票代號
  21.                 If A.Value = " 搜尋 " Then A.Click                     '按下 搜尋
  22.             Next
  23.             Do While .ReadyState <> 4 Or .Busy: DoEvents: Loop
  24.             For Each E In .document.ALL.TAGS("div")
  25.                 If E.ID = "table01" Then
  26.                     .document.body.innerHTML = E.outerHTML
  27.                     .ExecWB 17, 2       '  Select All
  28.                     .ExecWB 12, 2       '  Copy selection
  29.                     With ActiveSheet
  30.                         .Cells.Clear
  31.                         .Cells(1).Select
  32.                         .PasteSpecial Format:="HTML"
  33.                     End With
  34.                 End If
  35.             Next
  36.         .Quit                          '關閉 IE
  37.     End With
  38. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 4# blue2263

   
A1儲存格輸入股票代碼,A2年度,A3月份

程式碼中有註解 股票代碼 ,年度,月份
將那些=字串 取代為 A1,A2,A3
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 7# blue2263

A1是工作表上的位置, VBA 語法 Range("A1")
  1. If A.Name = "co_id" Then A.Value =Range("A1")        '股票代號
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 10# blue2263
參考這裡
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 14# blue2263
我將(讓視窗不跟隨更新變動),此行程式碼加入時,也一樣會有錯誤

你沒附檔,莫宰羊.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 16# blue2263
  1. Sub Macro()
  2.     Application.ScreenUpdating = False '讓視窗不跟隨更新變動
  3.     If ActiveCell.Value <> Empty Then
  4.         Application.CutCopyMode = False
  5.         Selection.Copy
  6.         Sheets("原始表").Select
  7.         Range("B2").Select
  8.         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  9.             :=False, Transpose:=False '貼上
  10.         On Error GoTo 101 '   '新增條件開始101
  11.         '*********************************************************************
  12.         'ActiveCell.Value應是這Sheets("原始表").Range("E7")QueryTable的股票代號
  13.         '但Sheets("巨集工作表").Select
  14.         'ActiveCell.Offset(1, 0).Range("A1").Select <-沒有股票代號
  15.         'Web的更新會錯誤 一直的 GoTo 101
  16.         Sheets("原始表").Range("E7").QueryTable.Refresh BackgroundQuery:=True
  17.         '*********************************************************************
  18.         'Application.Wait (Now + TimeValue("0:00:02"))
  19.         Sheets("匯總").Select
  20.         Range("A2:K21").Select
  21.         Selection.Copy
  22.         Range("A1").Select
  23.         Selection.End(xlDown).Select '到最底資料列
  24.         ActiveCell.Offset(1, 0).Range("A1").Select '下一列
  25.         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  26.                     :=False, Transpose:=False '貼上值
  27. 101
  28.         Sheets("代碼").Select   '修改這裡試試看
  29.         'Sheets("巨集工作表").Select
  30.         ActiveCell.Offset(1, 0).Range("A1").Select
  31.         Call Macro
  32.     End If
  33. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

本帖最後由 GBKEE 於 2014-1-4 08:57 編輯

回復 18# blue2263
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng(1 To 2) As Range
  4.     On Error Resume Next  '執行程式碼如有錯誤繼續執行下一個程式碼: 股票Web有錯誤時
  5.     With Sheets("巨集工作表")
  6.         Set Rng(1) = .Range("B2")
  7.         .Activate
  8.     End With
  9.     'Sheets("匯總").UsedRange.Offset(1).Clear   '用此程式碼" 如需清除舊有資料
  10.     Do While Rng(1) <> ""
  11.         Rng(1).Activate
  12.         With Sheets("原始表")
  13.             .Range("B2") = Rng(1)
  14.             .Range("E7").QueryTable.Refresh BackgroundQuery:=False
  15.             Set Rng(2) = .Range("A10:K29")   '你要的原始資料            
  16.         End With
  17.         If Err = 0 Then
  18.             Application.StatusBar = Rng(1) & " 匯入中"
  19.             With Sheets("匯總").Range("A1").End(xlDown).Offset(1)  
  20.                 .Range("A1:K20").Value = Sheets("匯總").Range("A2:K21").Value
  21.                 Rng(1).Parent.Hyperlinks.Add Anchor:=Rng(1).Offset(, 2), Address:="", SubAddress:=.Address(, , , 1), TextToDisplay:=.Parent.Name & "!" & .Address(0, 0)
  22.                 '重新設定超連結
  23.             End With
  24.             
  25.             '************'用此程式碼:配合需清除舊有資料 ******************************
  26.             'With Sheets("匯總").Range("A" & Sheets("匯總").Rows.Count).End(xlUp).Offset(1)
  27.             '   .Resize(Rng(2).Rows.Count, Rng(2).Columns.Count) = Rng(2).Value
  28.             '    Rng(1).Parent.Hyperlinks.Add Anchor:=Rng(1).Offset(, 2), Address:="", SubAddress:=.Address(, , , 1), TextToDisplay:=.Parent.Name & "!" & .Address(0, 0)
  29.             'End With
  30.             '********************************************
  31.             
  32.         Else
  33.             With Rng(1).Offset(, 2)
  34.                 .Hyperlinks.Delete  '股票Web錯誤:刪除超連結
  35.                 .Value = ""
  36.             End With
  37.             Err.Clear
  38.         End If
  39.         Set Rng(1) = Rng(1).Offset(1)
  40.     Loop
  41.     Application.StatusBar = " 工作 完成 !!"
  42. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 21# blue2263
20# 按下組鍵CTRL+ESC+PAUSE,停止巨集後,->然後再次執行巨集會變成無法自動執行巨集,,你的Excel有問題.

迴圈的程式少用 Copy(佔用資源,減緩速度),Select(切換位置,佔用時間),多參考範例,多練習,會進步的.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

本帖最後由 GBKEE 於 2014-1-5 07:10 編輯

回復 23# blue2263
你要多了解VBA的方法.屬性.函數

ActiveCell.Offset(0, 0).Range("A1").Select
分解:   .Offset(0, 0) :原位置
        .Offset(0, 0).Range("A1") :原位置的A1
           那不就一樣是 ActiveCell

10# 39行程式碼: 原位置下移一列位置
  1.   Set Rng(1) = Rng(1).Offset(1)
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 29# pollllopkimo

上傳檔案看看
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 好事要提得起,是非要放得下,成就別人即是成就自己。
返回列表 上一主題