Hsieh

回復 4# candy516
最主要是看不懂你所謂除權息的標是要填在哪裡?
請試舉例來說明，你資料要怎麼填法

Hsieh

回復 6# candy516

我不懂的是，Sheet1記載是2010/9/7  是除權日
但妳敘述時又是變成2010/9/8
若條件沒成立是往前找或是往後找
找到後要在C85寫入什麼值?
萬一除權後都沒回升又該如何?

Hsieh

回復 8# candy516

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Application.ScreenUpdating = False
   
4. With Sheet1
   
5.    For Each a In .Range(.[A2], .[A2].End(xlDown))
   
6.       d(a & Year(a.Offset(, 1))) = Array(a.Offset(, 1), a.Offset(, 2))
   
7.    Next
   
8. End With
   
9. For y = 2001 To 2010
   
10.   With Sheets(CStr(y))
    
11.     If Application.CountBlank(.Range(.[B1], .[IV1].End(xlToLeft))) > 0 Then .Range(.[B1], .[IV1].End(xlToLeft)).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    
12.     .Range(.[IV1].End(xlToLeft).Offset(, 1), .[IV1]).EntireColumn.Clear
    
13.     k = 2
    
14.     Do Until .Cells(1, k) = ""
    
15.     .Columns(k + 1).Insert
    
16.        mystr = .Cells(1, k) & y
    
17.        Set a = .Columns("A").Find(d(mystr)(0))
    
18.        If Not a Is Nothing Then
    
19.        cnt = 0
    
20.          r = a.Row
    
21.          test = .Cells(r - 1, k)
    
22.          r = r + 1
    
23.          cnt = cnt + 1
    
24.          Do Until .Cells(r, k) >= test Or .Cells(r, k) = ""
    
25.          cnt = cnt + 1
    
26.          r = r + 1
    
27.          Loop
    
28.          If .Cells(r, 1) = "" Then
    
29.          .Cells(a.Row, k + 1) = "無填權"
    
30.          Else
    
31.          .Cells(a.Row, k + 1) = cnt
    
32.          End If
    
33.        End If
    
34.        k = k + 2
    
35.     Loop
    
36.   End With
    
37. Next
    
38. Application.ScreenUpdating = True
    
39. End Sub

複製代碼

Hsieh

回復 10# candy516

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Application.ScreenUpdating = False
   
4. With Sheet1
   
5.    For Each a In .Range(.[A2], .[A2].End(xlDown))
   
6.       d(a & Year(a.Offset(, 1))) = a.Offset(, 1).Value
   
7.    Next
   
8. End With
   
9. For y = 2001 To 2010
   
10.   With Sheets(CStr(y))
    
11.     If Application.CountBlank(.Range(.[B1], .[IV1].End(xlToLeft))) > 0 Then .Range(.[B1], .[IV1].End(xlToLeft)).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    
12.     .Range(.[IV1].End(xlToLeft).Offset(, 1), .[IV1]).EntireColumn.Clear
    
13.     k = 2
    
14.     Do Until .Cells(1, k) = ""
    
15.     .Columns(k + 1).Insert
    
16.        mystr = .Cells(1, k) & y
    
17.        Set a = .Columns("A").Find(d(mystr))
    
18.        If Not a Is Nothing Then
    
19.        cnt = 0
    
20.          r = a.Row
    
21.          test = .Cells(r + 1, k)
    
22.          cnt = cnt + 1
    
23.          Do Until .Cells(r, k) >= test Or .Cells(r, k) = ""
    
24.          cnt = cnt + 1
    
25.          r = r - 1
    
26.          Loop
    
27.          If r <= 2 Then
    
28.          .Cells(a.Row, k + 1) = "無填權"
    
29.          Else
    
30.          .Cells(a.Row, k + 1) = cnt
    
31.          End If
    
32.        End If
    
33.        k = k + 2
    
34.     Loop
    
35.   End With
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub

複製代碼

Hsieh

回復 12# candy516

因為欄數過多必須使用2007版本

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Application.ScreenUpdating = False
   
4. With Sheet1
   
5.    For Each a In .Range(.[A2], .[A2].End(xlDown))
   
6.       d(a & Year(a.Offset(, 1))) = a.Offset(, 1).Value
   
7.    Next
   
8. End With
   
9. For y = 2001 To 2004
   
10.   With Sheets(CStr(y))
    
11.     If Application.CountBlank(.Range(.[B1], .[XFD1].End(xlToLeft))) > 0 Then .Range(.[B1], .[XFD1].End(xlToLeft)).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    
12.     .Range(.[XFD1].End(xlToLeft).Offset(, 1), .[XFD1]).EntireColumn.Clear
    
13.     k = 2
    
14.     Do Until .Cells(1, k) = ""
    
15.     .Columns(k + 1).Insert
    
16.        mystr = .Cells(1, k) & y
    
17.        Set a = .Columns("A").Find(d(mystr))
    
18.        If Not a Is Nothing Then
    
19.        cnt = 0
    
20.          r = a.Row
    
21.          test = .Cells(r + 1, k)
    
22.          cnt = cnt + 1
    
23.          Do Until .Cells(r, k) >= test Or .Cells(r, k) = ""
    
24.          cnt = cnt + 1
    
25.          r = r - 1
    
26.          Loop
    
27.          If r <= 2 Then
    
28.          .Cells(a.Row, k + 1) = "無填權"
    
29.          Else
    
30.          .Cells(a.Row, k + 1) = cnt
    
31.          End If
    
32.        End If
    
33.        k = k + 2
    
34.     Loop
    
35.   End With
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub

複製代碼

Hsieh

回復 15# candy516

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

Hsieh

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

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

複製代碼