FAlonso

自己做了一個,給其他會員看看,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
   
5. 
   
6. ThisWorkbook.Activate
   
7. 
   
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
    
41. 
    
42. End Sub

複製代碼

計算除權日.rar (289.3 KB)

下載次數: 3

2011-1-19 14:29

candy516

回復 20# Hsieh


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

Hsieh

回復 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
   
8. 
   
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

複製代碼

candy516

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