cji3cj6xu6 wrote:
一下子就拓展到了14...(恕刪)
超棒的
繼續爬文努力學習中 .....
謝謝 snare 大大
yuehmao wrote:
您好^^在下用的 Excel...(恕刪)
謝謝您的回應
感謝師兄弟的交流
有照您的意思改了activate了
還是一樣的狀況(泣)
另外,您的新增,刪除頁面那邊的寫法很有意思
Dim SheetExists As Boolean
SheetExists = False
學習中了,感謝您的分享~^^
---------------------
也有照師傅的方法修改
把DisplayAlerts全部弄掉
(我沒有dropbox,但有googledrive)
也是一樣
我是不會出現任何視窗上的錯誤(office2013)
沒有任何提示,如影片中的樣子
那我現在是覺得,既然師傅都搞不定了
我也沒必要在糾結這個點上
可能就是版本的問題
當然我是執著要用表單的
那不然
就加個select
選取其他頁面在選回來就好了XD
再次感謝各界大大的指導!!
yuehmao wrote:
這個問題現象蠻奇特的...(恕刪)
總算試出不能點選的問題了
問題出在一些表單控制項，如果建立後沒有選擇、active
會造成表單當掉，需切換到其它工作表，再切回來才正常
所以只跑副程式沒問題，如果自己另外建立一堆表單
或是把副程式複製到另一個有表單的檔案
假如其中一個控制項沒處理好，就會造成excel當住
測試用副程式，建立listbox 後，listbox 無法點選
Sub test()
ActiveSheet.DrawingObjects.Delete
Dim ChgFinSheet As OLEObject
Set ChgFinSheet = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ListBox.1")
With ChgFinSheet
.Object.IntegralHeight = False
.Object.Font.Size = 11
.Top = 100
.Left = 100
.Width = 130
.Height = 160
' .Parent.Select '這行啟用，就會正常
With ChgFinSheet.Object
.List = Array("資產負債表", "損益表", "現金流量表", "財務比率表")
End With
End With
End Sub
賣一下關子，正在做71樓範例的全自動版…
不過最近有點忙…要等等
因為範例都是寫好玩的，所以不是很用心，隨便測一下就po文
這次嚴重低估了71樓範例的修改難度+報表檢查不周全
造成換報表時，就算代碼改對，程式還是會出錯，只有範例中測試的那幾個報表不會出錯
我還一直以為我沒錯，造成大家的困擾，深感報歉
所以特別用心改寫71樓的範例
也用了很多比較少見的寫法
在此破例補上
台灣股市資訊網http://goodinfo.tw/StockInfo/index.asp
全自動範例(含排版)
'======程式碼請放在“表單按鈕”裡，，需新增一個名稱為"acc"的工作表=================
Private Sub CommandButton1_Click()
Call addlistbox
With Sheets("acc")
.Select
.Columns.ColumnWidth = 10
stock_id = InputBox("請輸入四碼股票代號" & vbNewLine & "(輸入後，也可以直接修改B2儲存格)")
If stock_id = "" Then
.Cells.Clear
.DrawingObjects.Delete
Sheets("sheet1").Select
Exit Sub
End If
.Cells(1, 1) = "股票代號"
.Cells(1, 2) = stock_id
.Cells(1, 2).Select
End With
End Sub
'======程式碼請放在“模組”裡面======
Sub addlistbox()
Dim list_0, list_1, list_2, download
With Sheets("acc")
.Cells.Clear
.DrawingObjects.Delete
Set list_0 = .ListBoxes.Add(.Range("b7").Left + 5, .Range("b7").Top, 100, 100)
With list_0
.Name = "list_0"
list_0.List = listdata(0)
.Selected(1) = True
.OnAction = "list_0_change"
End With
Set list_1 = .ListBoxes.Add(.Range("d7").Left + 5, Range("d7").Top, 100, 100)
With list_1
.Name = "list_1"
list_1.List = listdata(1)
.Selected(1) = True
.OnAction = "list_1_change"
End With
Set list_2 = .ListBoxes.Add(.Range("f7").Left + 5, Range("f7").Top, 100, 100)
With list_2
.Name = "list_2"
list_2.List = listdata(6)
.Selected(1) = True
.OnAction = "list_2_change"
End With
Set download = .Buttons.Add(.Range("f14").Left + 5, Range("f14").Top, 80, 30)
With download
.Name = "download"
.Caption = "按我下載"
.OnAction = "download"
End With
.Select
.Cells(5, 2) = "請選擇財務報表": .Cells(5, 4) = "請選擇季表、年表": .Cells(5, 6) = "請選擇年份、季別"
.Cells(1, 1).Select
End With
End Sub
Sub getpost(url, url_a, accname)
Dim HTMLsourcecode, Clipboard As Object
Set HTMLsourcecode = CreateObject("htmlfile")
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "POST", url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", url_a
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.Send
HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)
If InStr(HTMLsourcecode.body.innertext, "查 無 資 料 !!") > 0 Then
Sheets("acc").Cells(1, 1) = "查無資料"
Exit Sub
End If
With Clipboard
.SetText HTMLsourcecode.body.innerhtml
.PutInClipboard
End With
With Sheets("acc")
.Select
.Cells.Clear
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=True
.Cells(1, 1) = Replace(.Cells(1, 1), "(載入中...)", "")
.Cells(2, 1).Select
.DrawingObjects.Delete
' .ListBoxes("list_0").Delete
' .ListBoxes("list_1").Delete
' .ListBoxes("list_2").Delete
' .Buttons("download").Delete
End With
End With
Call typesetting(accname) '這個副程式可以不要用，單純只是排版而己
End Sub
Sub download()
With Sheets("acc")
stock_id = Range("b1")
list_0_data = Split(.ListBoxes("list_0").List(.ListBoxes("list_0")), ",")(1)
list_1_data = Split(.ListBoxes("list_1").List(.ListBoxes("list_0")), ",")(1)
list_2_data = Split(.ListBoxes("list_2").List(.ListBoxes("list_0")), ",")(1)
url = "http://goodinfo.tw/StockInfo/StockFinDetail.asp?STEP=DATA&STOCK_ID=" & stock_id & "&RPT_CAT=" & list_1_data & "&QRY_TIME=" & list_2_data
url_a = "http://goodinfo.tw/StockInfo/StockFinDetail.asp?RPT_CAT=" & list_0_data & "&STOCK_ID=" & stock_id
End With
Call getpost(url, url_a, list_0_data)
End Sub
Sub list_0_change()
With Sheets("acc")
.ListBoxes("list_1").List = listdata(.ListBoxes("list_0").ListIndex)
.ListBoxes("list_1").Selected(1) = True
End With
End Sub
Sub list_1_change()
With Sheets("acc")
If InStr(.ListBoxes("list_1").List(.ListBoxes("list_1").ListIndex), "季表") = 0 Then
.ListBoxes("list_2").List = listdata(5)
Else
.ListBoxes("list_2").List = listdata(6)
End If
.ListBoxes("list_2").Selected(1) = True
End With
End Sub
Sub list_2_change()
With Sheets("acc")
'debug
End With
End Sub
Sub typesetting(accname)
Application.ScreenUpdating = False
With Sheets("acc")
lastrow = .UsedRange.Rows.Count
lastcol = .UsedRange.Columns.Count
.Range("a1:e1").Merge
.Range("a1:e1").Font.Bold = True
.Columns.ColumnWidth = 10
.Columns(1).ColumnWidth = 20
.Columns(1).WrapText = True
For i = 4 To lastrow - 1
If (accname = "CF_M_QUAR_ACC" Or accname = "XX_M_QUAR_ACC") Then shift = 0 Else shift = 1
If .Cells(i, 1) <> "" And (InStr(.Cells(i, 2), "Q") > 0 Or (.Cells(i, 2) <> "-" And .Cells(i, 2) > 1980 And .Cells(i, 3) > 1980) Or .Cells(i + shift, 1) = "") Then
With .Range(Cells(i, 1), Cells(i + shift, lastcol))
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Font.Bold = True
.Interior.Color = 16764057
End With
.Range(Cells(i, 1), Cells(i, lastcol)).HorizontalAlignment = xlCenter
If shift = 1 Then
.Range(Cells(i + 1, 1), Cells(i + 1, lastcol)).HorizontalAlignment = xlRight
.Range(Cells(i, 1), Cells(i + 1, 1)).Merge
End If
For j = 2 To lastcol Step 2
If shift = 1 Then .Range(Cells(i, j), Cells(i, j + 1)).Merge
' .Columns(j + 1).Font.Bold = True
Next j
End If
For k = 2 To lastcol
If .Cells(i, k) < 0 Then
.Cells(i, k).Font.Color = -16776961
End If
Next k
If (accname = "XX_M_QUAR_ACC" And .Cells(i, 2) = "") Then .Cells(i, 1) = ""
Next i
If accname = "XX_M_QUAR_ACC" Then
Range(Cells(4, 1), Cells(lastrow, lastcol)).SpecialCells(xlCellTypeBlanks, xlErrors).EntireRow.Delete shift:=xlUp
End If
End With
Application.ScreenUpdating = True
End Sub
Function listdata(choose)
Dim temp
yearrange = Year(Date) - 1980
monthrange = ((yearrange) * 4) + ((Month(Date) - 1) \ 4)
Select Case choose
Case 0
listdata = Array("資產負債表" & Space(30) & ",BS_M_QUAR", "損益表" & Space(30) & ",IS_M_QUAR_ACC", "現金流量表" & Space(30) & ",CF_M_QUAR_ACC", "財務比率表" & Space(30) & ",XX_M_QUAR_ACC")
Case 1
listdata = Array("合併季表" & Space(30) & ",BS_M_QUAR", "合併年表" & Space(30) & ",BS_M_YEAR", "非合併季表" & Space(30) & ",BS_QUAR", "非合併年表" & Space(30) & ",BS_YEAR", "合併簡式季表" & Space(30) & ",BS_EZ_M_QUAR", "合併簡式年表" & Space(30) & ",BS_EZ_QUAR", "非合併簡式季表" & Space(30) & ",BS_EZ_QUAR", "非合併簡式年表" & Space(30) & ",BS_EZ_YEAR")
Case 2
listdata = Array("合併單季季表" & Space(30) & ",IS_M_QUAR", "合併累計季表" & Space(30) & ",IS_M_QUAR_ACC", "合併年表" & Space(30) & ",IS_M_YEAR", "非合併單季季表" & Space(30) & ",IS_QUAR", "非合併累計季表" & Space(30) & ",IS_QUAR_ACC", "非合併年表" & Space(30) & ",IS_YEAR", "合併簡式單季季表" & Space(30) & ",IS_EZ_M_QUAR", "合併簡式累計季表" & Space(30) & ",IS_EZ_M_QUAR_ACC", "合併簡式年表" & Space(30) & ",IS_EZ_M_YEAR", "非合併簡式單季季表" & Space(30) & ",IS_EZ_QUAR", "非合併簡式累計季表" & Space(30) & ",IS_EZ_QUAR_ACC", "非合併簡式年表" & Space(30) & ",IS_EZ_YEAR")
Case 3
listdata = Array("合併單季季表" & Space(30) & ",CF_M_QUAR", "合併累計季表" & Space(30) & ",CF_M_QUAR_ACC", "合併年表" & Space(30) & ",CF_M_YEAR", "非合併單季季表" & Space(30) & ",CF_QUAR", "非合併累計季表" & Space(30) & ",CF_QUAR_ACC", "非合併年表" & Space(30) & ",CF_YEAR")
Case 4
listdata = Array("合併單季季表" & Space(30) & ",XX_M_QUAR", "合併累計季表" & Space(30) & ",XX_M_QUAR_ACC", "合併年表" & Space(30) & ",XX_M_YEAR", "非合併單季季表" & Space(30) & ",XX_QUAR", "非合併累計季表" & Space(30) & ",XX_QUAR_ACC", "非合併年表" & Space(30) & ",XX_YEAR")
Case 5
ReDim temp(yearrange)
For i = 0 To yearrange
temp(i) = (Year(Date) - i) & "年" & Space(30) & "," & (Year(Date) - i)
Next i
listdata = Application.Transpose(temp)
Erase temp
Case 6
ReDim temp(monthrange)
k = 0
For i = 0 To yearrange
For j = 1 To 4
If k <= monthrange Then
temp(monthrange - k) = 1980 + i & "Q" & j & Space(30) & "," & 1980 + i & j
k = k + 1
End If
Next j
Next i
listdata = Application.Transpose(temp)
Erase temp
End Select
End Function
Function convertraw(rawdata)
Dim rawstr
Set rawstr = CreateObject("adodb.stream")
With rawstr
.Type = 1
.Mode = 3
.Open
.Write rawdata
.Position = 0
.Type = 2
.Charset = "utf-8"
convertraw = .ReadText
.Close
End With
Set rawstr = Nothing
End Function
'=============================
自動化範例(含排版)
附加壓縮檔: 201802/mobile01-2e9fff3def8b7117cbc38d0e7ea881f1.zip
內文搜尋
從 APP 打開
X