[發問] 求助~關於vba的程式!

帖子: 47
主題: 5
精華: 0
積分: 116
點名: 0
作業系統: XP
軟體版本: office2007
閱讀權限: 20
性別: 女
註冊時間: 2011-1-14
最後登錄: 2012-3-10

24^#

發表於 2011-1-21 00:10 | 只看該作者

回復 23# Hsieh
謝謝你的幫忙!
我目前是分兩個程式執行：
第一：先將所有股價的欄位都刪除
Sub delcol()
Dim i%, c As Range
Set c = Columns(2)
For i = 4 To [iv1].End(1).Column Step 2
Set c = Union(c, Columns(i))
Next
c.Delete
End Sub
第二：再將空格刪除，把資料往上補，在後再將其結果轉置。
Sub ex1()
Columns("B:CF").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub
因為我後來想說，我先不要設定所謂有完成填權的天數，
這樣彈性比較大!而我到時候想看"幾天"完成填權的公司，
再用EXCEL篩選功能即可!
真的很謝謝你耐心的幫忙!
^^

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 254
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-23

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

23^#

發表於 2011-1-20 13:36 | 只看該作者

回復 22# candy516
這樣可能麻煩一點
程式將填入填權日數，並將10日內填權名單列出
請將程式碼置於Sheet1模組

Sub 填權()
Dim A As Range, Ar()
Set dic = CreateObject("Scripting.Dictionary")
Set myday = CreateObject("Scripting.Dictionary")
ReDim Preserve Ar(z)
Ar(z) = Array("公司", "年度", "填權日數")
z = z + 1
Dim Sh As Worksheet
For j = Sheets.Count To 1 Step -1
Set Sh = Sheets(j)
With Sh
If .Name <> Me.Name Then
Set rng = .Range(.[B1], .Cells(1, .Columns.Count).End(xlToLeft))
If Application.CountBlank(rng) > 0 Then rng.SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
For r = .Cells(.Rows.Count, 1).End(xlUp).Row To 3 Step -1
Set A = .Cells(r, 1)
myday(A.Value) = temp
temp = A.Value
Next
Else
For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(3))
dic(A & Year(A.Offset(, 1))) = A.Offset(, 1)
Next
End If
End With
Next
For Each Sh In Sheets
With Sh
If .Name < Me.Name Then
k = 2: dn = .Name
Do Until .Cells(1, k) = ""
.Columns(k + 1).Insert
f = .Cells(1, k)
Set A = .Columns("A").Find(dic(f & dn))
If A Is Nothing Then GoTo 20
d = myday(A.Value)
With Sheets(CStr(Year(d)))
Set b = .Columns("A").Find(d)
Set c = .Rows(1).Find(f)
If b Is Nothing Or c Is Nothing Then cnt = "無填權": GoTo 10
x = b.Row
y = c.Column
test = .Cells(x, y)
End With
r = A.Row: cnt = 1
Do Until r = 2 Or .Cells(r, k) >= test
r = r - 1
cnt = cnt + 1
Loop
If r = 2 Then cnt = "無填權"
10
.Cells(A.Row, k + 1) = cnt
If IsNumeric(cnt) And cnt <= 10 Then
ReDim Preserve Ar(z)
Ar(z) = Array(f, dn, cnt)
z = z + 1
End If
20
k = k + 2
Loop
End If
End With
Next
Set dic = Nothing
Set myday = Nothing
With Worksheets.Add
.[A1].Resize(z, 3) = Application.Transpose(Application.Transpose(Ar))
.Move
End With
End Sub

複製代碼

學海無涯_不恥下問

帖子: 47
主題: 5
精華: 0
積分: 116
點名: 0
作業系統: XP
軟體版本: office2007
閱讀權限: 20
性別: 女
註冊時間: 2011-1-14
最後登錄: 2012-3-10

22^#

發表於 2011-1-19 15:44 | 只看該作者

回復 20# Hsieh

你好~
但是每個年度有除權的公司不太一樣~
所以要把它合併到同一張工作表中似乎有一點困難!
謝謝!

FAlonso

帖子: 135
主題: 19
精華: 0
積分: 165
點名: 0
作業系統: XP
軟體版本: 2003
閱讀權限: 20
性別: 男
來自: 香港
註冊時間: 2010-12-9
最後登錄: 2012-8-27

21^#

發表於 2011-1-19 14:31 | 只看該作者

本帖最後由 FAlonso 於 2011-1-19 14:33 編輯

自己做了一個,給其他會員看看,excel文件稍為做了一些修改,把空column給刪掉
不能下載的話,請看下列程式

Sub chooseyellowcell2()
Dim i As Integer, myfinalrow As Integer
Dim mycell As Range, mycolumn As Range, mycell2 As Range, mytarget As Range, mybaseline As Range, mycheck As Range
Dim checkstatus As Boolean
ThisWorkbook.Activate
For i = 2 To Worksheets.Count
Sheets(i).Activate
myfinalrow = ActiveSheet.Range("A2").End(xlDown).Offset(1).Row
For Each mycell In ActiveSheet.Range("A1", Range("IV1").End(xlToLeft))
If mycell.Value <> "" Then
Set mycolumn = Range(mycell, mycell.End(xlDown))
For Each mycell2 In mycolumn
If mycell2.Interior.ColorIndex = 6 Then
checkstatus = False
Set mybaseline = mycell2.Offset(1)
Set mycheck = mycell2
If mybaseline.Value = "" Then
mybaseline.Value = "無法計算"
Exit For
Else
Do
If mycheck.Value >= mybaseline.Value Then
ActiveSheet.Cells(myfinalrow, mycheck.Column) = mybaseline.Row - mycheck.Row
checkstatus = True
Exit Do
Else
Set mycheck = mycheck.Offset(-1)
End If
Loop While checkstatus = False And IsNumeric(mycheck) = True
If checkstatus = False Then
mycheck.End(xlDown).Offset(1).Value = "無填權"
End If
End If
End If
Next
End If
Next
Next
End Sub

複製代碼

計算除權日.rar (289.3 KB)

80 字節以內
不支持自定義 Discuz! 代碼

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 254
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-23

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

20^#

發表於 2011-1-19 13:26 | 只看該作者

回復 19# candy516
比較好的方式是把所有年度資料都整理在同一工作表中
跨年跨月的問題就容易解決

學海無涯_不恥下問

帖子: 47
主題: 5
精華: 0
積分: 116
點名: 0
作業系統: XP
軟體版本: office2007
閱讀權限: 20
性別: 女
註冊時間: 2011-1-14
最後登錄: 2012-3-10

19^#

發表於 2011-1-18 23:28 | 只看該作者

回復 18# FAlonso

你好~
我都沒發現到這個問題耶!
日勝生在2003/01/02除權，其實它應該要跟2002/12/31的收盤價做比較!
因為我是分年度抓資料的,所以忽略了這一點!= =
日數都是交易日沒錯!
^^

FAlonso

帖子: 135
主題: 19
精華: 0
積分: 165
點名: 0
作業系統: XP
軟體版本: 2003
閱讀權限: 20
性別: 男
來自: 香港
註冊時間: 2010-12-9
最後登錄: 2012-8-27

18^#

發表於 2011-1-18 20:33 | 只看該作者

本帖最後由 FAlonso 於 2011-1-18 20:45 編輯

不好意思,我發現一些問題
2003年Z行股票"日勝生",黃色格子是最後一行
根據你的說法,計算日子的方法是把黃色格子及黃色格子位置以上的格子* 和黃色格子以下的一格作比較
現在黃色格子下面沒有東西,怎辦?

*指若黃色格子是C10,所謂以上的格子是C9,C8,........云云,黃色以下的一格代表C11云云

還有中間的日數是否指trading days?

80 字節以內
不支持自定義 Discuz! 代碼

帖子: 47
主題: 5
精華: 0
積分: 116
點名: 0
作業系統: XP
軟體版本: office2007
閱讀權限: 20
性別: 女
註冊時間: 2011-1-14
最後登錄: 2012-3-10

17^#

發表於 2011-1-18 00:01 | 只看該作者

看起來儲存格格式是一樣，我已經把資料重抓一便!
重抓就OK了!
^^
謝謝!

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 254
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-23

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

16^#

發表於 2011-1-17 21:58 | 只看該作者

回復 15# candy516

那要看你的格式是否跟其他年度一樣

學海無涯_不恥下問