123
返回列表 上一主題 發帖

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

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給刪掉
不能下載的話,請看下列程式
  1. Sub chooseyellowcell2()
  2. Dim i As Integer, myfinalrow As Integer
  3. Dim mycell As Range, mycolumn As Range, mycell2 As Range, mytarget As Range, mybaseline As Range, mycheck As Range
  4. Dim checkstatus As Boolean

  6. ThisWorkbook.Activate

  8. For i = 2 To Worksheets.Count
  9.     Sheets(i).Activate
  10.     myfinalrow = ActiveSheet.Range("A2").End(xlDown).Offset(1).Row
  11.         For Each mycell In ActiveSheet.Range("A1", Range("IV1").End(xlToLeft))
  12.             If mycell.Value <> "" Then
  13.             Set mycolumn = Range(mycell, mycell.End(xlDown))
  14.                 For Each mycell2 In mycolumn
  15.                     If mycell2.Interior.ColorIndex = 6 Then
  16.                         checkstatus = False
  17.                         Set mybaseline = mycell2.Offset(1)
  18.                         Set mycheck = mycell2
  19.                             If mybaseline.Value = "" Then
  20.                             mybaseline.Value = "無法計算"
  21.                             Exit For
  22.                             Else
  23.                             Do
  24.                                 If mycheck.Value >= mybaseline.Value Then
  25.                                 ActiveSheet.Cells(myfinalrow, mycheck.Column) = mybaseline.Row - mycheck.Row
  26.                                 checkstatus = True
  27.                                 Exit Do
  28.                                 Else
  29.                                 Set mycheck = mycheck.Offset(-1)
  30.                                 End If
  31.                             Loop While checkstatus = False And IsNumeric(mycheck) = True
  32.                                 If checkstatus = False Then
  33.                                 mycheck.End(xlDown).Offset(1).Value = "無填權"
  34.                                 End If
  35.                             End If
  36.                     End If
  37.                 Next
  38.             End If
  39.         Next
  40. Next

  42. End Sub
複製代碼
計算除權日.rar (289.3 KB)
80 字節以內
不支持自定義 Discuz! 代碼

TOP

candy516

帖子
47 
主題
5 
精華
0 
積分
116 
點名
0  
作業系統
XP 
軟體版本
office2007 
閱讀權限
20 
性別
女 
註冊時間
2011-1-14 
最後登錄
2012-3-10 
22#
發表於 2011-1-19 15:44 | 只看該作者
回復 20# Hsieh


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

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
23#
發表於 2011-1-20 13:36 | 只看該作者
回復 22# candy516
這樣可能麻煩一點
程式將填入填權日數，並將10日內填權名單列出
請將程式碼置於Sheet1模組
  1. Sub 填權()
  2. Dim A As Range, Ar()
  3. Set dic = CreateObject("Scripting.Dictionary")
  4. Set myday = CreateObject("Scripting.Dictionary")
  5.           ReDim Preserve Ar(z)
  6.           Ar(z) = Array("公司", "年度", "填權日數")
  7.           z = z + 1

  9. Dim Sh As Worksheet
  10. For j = Sheets.Count To 1 Step -1
  11. Set Sh = Sheets(j)
  12.   With Sh
  13.      If .Name <> Me.Name Then
  14.      Set rng = .Range(.[B1], .Cells(1, .Columns.Count).End(xlToLeft))
  15.         If Application.CountBlank(rng) > 0 Then rng.SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
  16.         For r = .Cells(.Rows.Count, 1).End(xlUp).Row To 3 Step -1
  17.         Set A = .Cells(r, 1)
  18.            myday(A.Value) = temp
  19.            temp = A.Value
  20.         Next
  21.         Else
  22.         For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(3))
  23.         dic(A & Year(A.Offset(, 1))) = A.Offset(, 1)
  24.         Next
  25.     End If
  26.   End With
  27. Next
  28. For Each Sh In Sheets
  29.   With Sh
  30.   If .Name < Me.Name Then
  31.   k = 2: dn = .Name
  32.     Do Until .Cells(1, k) = ""
  33.        .Columns(k + 1).Insert
  34.        f = .Cells(1, k)
  35.        Set A = .Columns("A").Find(dic(f & dn))
  36.        If A Is Nothing Then GoTo 20
  37.        d = myday(A.Value)
  38.        With Sheets(CStr(Year(d)))
  39.           Set b = .Columns("A").Find(d)
  40.           Set c = .Rows(1).Find(f)
  41.           If b Is Nothing Or c Is Nothing Then cnt = "無填權": GoTo 10
  42.           x = b.Row
  43.           y = c.Column
  44.           test = .Cells(x, y)
  45.        End With
  46.        r = A.Row: cnt = 1
  47.        Do Until r = 2 Or .Cells(r, k) >= test
  48.        r = r - 1
  49.        cnt = cnt + 1
  50.        Loop
  51.        If r = 2 Then cnt = "無填權"
  52. 10
  53.        .Cells(A.Row, k + 1) = cnt
  54.        If IsNumeric(cnt) And cnt <= 10 Then
  55.           ReDim Preserve Ar(z)
  56.           Ar(z) = Array(f, dn, cnt)
  57.           z = z + 1
  58.        End If
  59.       
  60. 20
  61.        k = k + 2
  62.     Loop
  63.   End If
  64.   End With
  65. Next
  66. Set dic = Nothing
  67. Set myday = Nothing
  68. With Worksheets.Add
  69. .[A1].Resize(z, 3) = Application.Transpose(Application.Transpose(Ar))
  70. .Move
  71. End With
  72. End Sub
複製代碼
學海無涯_不恥下問

TOP

candy516

帖子
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篩選功能即可!
真的很謝謝你耐心的幫忙!
^^

TOP

        靜思自在 : 人要自愛，才能愛普天下的人。
123
返回列表 上一主題