GBKEE

回復 10# espionage
網頁上的股票代號查詢後會不會消失不見.端看各網頁原始碼的寫法.

s13983037

回復 9# GBKEE

Hi GBKEE您好
看到您的程式碼 想把他修正成 個股的集保日期
當第一筆日期輸入時填入 A1欄中
但是第二筆資料輸入時填入A28欄中
以此類推每一筆資料填入後都需間隔28欄位,
目前我只有修正到可以重複填入日期的部分,請教GBKEE 前輩 不知要如何修改,可否提點迷津 感謝您\QQ/

以下為修正程式碼

    Dim Ar(), a, i As Integer, strDate As String, stkno As String, Qur As String
    With CreateObject("InternetExplorer.Application")
        .Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
        Set a = .Document.ALL.tags("option") '資料日期的內容
        ReDim Ar(a.Length - 1)
        For i = 0 To a.Length - 1
            Ar(i) = a(i).innerHTML
        Next
        .Quit
    End With
   
    For DateVar = 0 To 28
    strDate = Ar(DateVar) '導入當月日期
    Do
        strDate = InputBox(Join(Ar, vbTab), "集保戶股權分散表查詢 之 有效日期", strDate)
        If strDate = "" Then Exit Sub
     
    Loop Until IsNumeric(Application.Match(strDate, Ar, 0))
    stkno = InputBox("輸入股票代號", "股票代號", 2313)    '
    If stkno = "" Then Exit Sub
    Qur = "http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE=" & strDate & "&SqlMethod=StockNo&StockNo=" & stkno & "&StockName=&sub=%ACd%B8%DF"
    With ActiveSheet
                                For WriteDate = 1 To 1
                                        If .QueryTables.Count = 0 Then
                                                .QueryTables.Add "URL;" & Qur, .[A & WriteDate * 28 * (WriteDate) ]
                                        Else
                                                .QueryTables(1).Connection = "URL;" & Qur
                                        End If
                                        With .QueryTables(1)
                                                .WebSelectionType = xlSpecifiedTables
                                                .WebFormatting = xlWebFormattingNone
                                                .WebTables = "6,7,8"
                                                .WebPreFormattedTextToColumns = True
                                                .WebConsecutiveDelimitersAsOne = True
                                                .WebSingleBlockTextImport = False
                                                .WebDisableDateRecognition = False
                                                .WebDisableRedirections = False
                                                .Refresh BackgroundQuery:=False
                                        End With
                                Next
    End With
    Next

GBKEE

回復 12# s13983037
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Ar(), a As Variant, i As Integer, stkno As String, Qur As String, DateVar As Integer, Sh As Worksheet
   
4.     With CreateObject("InternetExplorer.Application")
   
5.         .Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
   
6.         Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
   
7.         Set a = .Document.ALL.tags("option") '資料日期的內容
   
8.         ReDim Ar(a.Length - 1)
   
9.         For i = 0 To a.Length - 1
   
10.             Ar(i) = a(i).innerHTML
    
11.         Next
    
12.         .Quit
    
13.     End With
    
14.     stkno = InputBox("輸入股票代號", "股票代號", 2313)    '
    
15.     If stkno = "" Then Exit Sub
    
16.     Set Sh = ActiveSheet             '指定工作表
    
17.     With Sh
    
18.         For DateVar = 0 To UBound(Ar)
    
19.             Qur = "http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE=" & Ar(DateVar) & "&SqlMethod=StockNo&StockNo=" & stkno & "&StockName=&sub=%ACd%B8%DF"
    
20.             .QueryTables.Add "URL;" & Qur, .Cells(1 + (DateVar * 27), "A")
    
21.             '.Cells(1 + (DateVar * 27), "A")  A欄間隔 27列
    
22.             With .QueryTables(1)
    
23.                 .WebSelectionType = xlSpecifiedTables
    
24.                 .WebFormatting = xlWebFormattingNone
    
25.                 .WebTables = "6,7,8"
    
26.                 .WebPreFormattedTextToColumns = True
    
27.                 .WebConsecutiveDelimitersAsOne = True
    
28.                 .WebSingleBlockTextImport = False
    
29.                 .WebDisableDateRecognition = False
    
30.                 .WebDisableRedirections = False
    
31.                 .Refresh BackgroundQuery:=False
    
32.                 Sh.Names(.Name).Delete '刪掉工作表上的名稱
    
33.                 .Delete                '刪掉這QueryTable
    
34.             End With
    
35.         Next
    
36.     End With
    
37. End Sub

複製代碼

s13983037

回復 13# GBKEE
Hi GBKEE前輩
謝謝您 可以用!!!

espionage

Hi GBKEE 大大
我找了一台有IE8的電腦，您的原始程式可以執行，原來IE版本會有這樣的影響
謝謝指教

chang0833

可以請各位先進幫忙解答這問題嗎？
1.本使用著超版GBKEE所提供的程式，但最近
    在下載時，卻連網頁背景顏色都下載下來(原只有文字沒背景)
    是什麼原因造成的？

GBKEE

回復 16# chang0833

1. .PreserveFormatting = False   '程式碼上加上這行
   
2.                 .Refresh BackgroundQuery:=False
   
3.                 Sh.Names(.Name).Delete '刪掉工作表上的名稱

複製代碼

chang0833

回復 17# GBKEE

謝謝版大開解^^

chang0833

回復 18# chang0833

在冒昧請超版GBKEE
下載會出現這格式的變動，是因為網站的網頁程式本身變動造成的嗎？

chang0833

不好意思，問題多了點
煩請GBKEE大大提點!!
我此次下次下載下來，連帶的連整個網頁表格的格式都一起下載下來
如何才能只下載純資料就好，不要有任何網頁表格格式？