pupai

回復 20# GBKEE


    有勞G大
  感恩!!
PS:原來我可以接著問,謝謝提點

pupai

回復 20# GBKEE


    請問G大
我加上巨集後
結果是我要的版面沒錯
但我從Web查詢的資料卻沒有出現
請指導!!   謝謝!!

pupai

請問
目前程式得到的結果 可以讓每個Web下載的分頁有Sheet1的版面
但是 從Web下載的資料卻沒有出現
請問要如何讓每一次Web下載的資料呈現，且同時又可以附帶有Sheet1相同的版面
謝謝!!

GBKEE

回復 23# pupai
應該是在這繼續發問的

附檔試試看對否
text.rar (16.57 KB)

下載次數: 8

2013-11-1 16:40

pupai

回復 24# GBKEE


    可以了
我先吸收一下
謝謝!!

pupai

1. Option Explicit
   
2. Sub GetData()
   
3.     Dim DataSheet As Worksheet, Sh As Worksheet
   
4.     Dim EndDate As Date, StartDate As Date, AR, xR As Long
   
5.     Dim Symbol As Variant, Qur As String
   
6.     Set DataSheet = Sheets("代碼")
   
7.     With DataSheet
   
8.         StartDate = .[C1]
   
9.         EndDate = .[C2]
   
10.         '本資料自民國94年09月01日開始提供 *** 除錯  ***
    
11.         If StartDate < #9/1/2005# Or EndDate < #9/1/2005# Or StartDate > EndDate Or EndDate > Date Then
    
12.             MsgBox "數據有誤" & IIf(StartDate < #9/1/2005#, vbLf & "StartDate :日期 小於 94年09月01日  ", "") & _
    
13.             IIf(EndDate < #9/1/2005#, vbLf & "EndDate :日期 小於 94年09月01日  ", "") & _
    
14.             IIf(StartDate > EndDate, vbLf & "StartDate > EndDate", "") & _
    
15.             IIf(EndDate > Date, vbLf & " EndDate >" & Date, "")
    
16.             Exit Sub
    
17.         End If
    
18.     '*********************************************
    
19.         Application.DisplayAlerts = False
    
20.         For Each Sh In Sheets
    
21.             If Sh.Name <> DataSheet.Name Then Sh.Delete    '刪除不必要的工作
    
22.         Next
    
23.         For Each Symbol In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))  '股票的迴圈
    
24.             StartDate = .[C1]                           '迴圈需重新回到原本的 StartDate日期
    
25.             Set Sh = Sheets.Add(, Sheets(Sheets.Count)) '新增的工作表位於活頁簿最後面(Sheets.Count)
    
26.             DataSheet.Activate
    
27.             Do While DateSerial(Year(StartDate), Month(StartDate), 1) <= EndDate
    
28.                 Qur = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?myear=" & Format(StartDate, "yyyy") & "&mmon=" & Format(StartDate, "m") & "&STK_NO=" & Symbol
    
29.                 With Sh       '新增的工作表
    
30.                     If .QueryTables.Count = 0 Then                      'Web查詢
    
31.                         .QueryTables.Add "URL;" & Qur, .[M1]            'Web查詢資料在M欄
    
32.                     Else
    
33.                         .QueryTables(1).Connection = "URL;" & Qur
    
34.                     End If
    
35.                     With .QueryTables(1)
    
36.                         .WebFormatting = xlWebFormattingNone
    
37.                         .WebSelectionType = xlSpecifiedTables
    
38.                         .WebDisableDateRecognition = True
    
39.                         .WebTables = "7,8"
    
40.                         .Refresh BackgroundQuery:=False
    
41.                          If Application.CountA(.ResultRange) > 1 Then
    
42.                             AR = .ResultRange.Offset(4)
    
43.                             If Application.CountA(.Parent.[a:a]) = 0 Then AR = .ResultRange.Offset(3)
    
44.                             xR = Application.CountA(.Parent.[a:a]) + 1                         '.Parent :Web查詢的父層
    
45.                             .Parent.Cells(xR, "A").Resize(UBound(AR, 1), UBound(AR, 2)) = AR   '資料複製到 新增工作表的A欄
    
46.                         End If
    
47.                     End With
    
48.                     
    
49.                 End With
    
50. 
    
51.                 StartDate = DateAdd("m", 1, StartDate)   '日期 + 1個月
    
52.             Loop
    
53.             With Sh
    
54.                 .Name = Symbol                                 '以股票命名
    
55.                 '------------------------
    
56.                 .Activate
    
57.                 .Range("A:A").Select
    
58.                 Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    
59.                 TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    
60.                 Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
    
61.                 :=Array(1, 10), TrailingMinusNumbers:=True
    
62. 
    
63.    
    
64.                 .Range("f1").Select
    
65.                 Application.CutCopyMode = False
    
66.                 ActiveSheet.Paste
    
67.             
    
68.                .Range("F19") = Symbol
    
69.                
    
70.                .Range("G19:L19").Select
    
71.                
    
72.                 '------------------------
    
73.                 .QueryTables(1).ResultRange = ""               '清除Web查詢的資料
    
74.                  .Names(.QueryTables(1).Name).Delete           'Web查詢的名稱
    
75.             End With
    
76.         Next
    
77.     End With
    
78.     Application.DisplayAlerts = True
    
79. End Sub

複製代碼

先跟各位報告還是以G大的版本比較好
這是我先前修改的程式 不好用
原因
  .Range("A:A").Select
                Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                :=Array(1, 10), TrailingMinusNumbers:=True
這一段如果遇到沒有資料 程式會停擺

另外這一段
.Range("f1").Select
                Application.CutCopyMode = False
                ActiveSheet.Paste
雖然可以複製格式 但是陣列公式沒法啟動

以上跟各位交流
再次感謝G大的用心 謝謝