標題: [發問] 篩選資料並且放到新的Sheet裡 [打印本頁]

---

作者: candy516    時間: 2011-3-23 01:47     標題: 篩選資料並且放到新的Sheet裡

本帖最後由 candy516 於 2011-3-23 01:48 編輯

各位前輩你們好：
    我又有一個問題想要請教大家，是關於資料篩選的!我本來想用人工手動的方法一筆一筆篩選，但我的指導教授一直叫我寫程式= = 但我是個超級超級新手，也沒有正式學過VBA!Sheet1是每檔股票的除息日，Sheet2~11則是十年間每股的日報酬率。最後一個Sheet是我想要的結果。接下來我需要篩選出每一檔股票在除息日後14天的日報酬率(包含除息日共15天)。舉列來說，在Sheet1中2010的1234黑松它的除息日是20100719，則在Sheet2中將20100719~20100801黑松的日報酬率抓至一個新的Sheet中(包含日期也一起抓)。請問這樣繁瑣的步驟，VBA可以辦到嗎?
希望各位可以幫幫我!謝謝!

---

作者: GBKEE    時間: 2011-3-23 08:57

回復 1# candy516
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, 除息日 As Date, 股票 As Range, R As Range, Ar(), i As Integer
   
4.     With Sheets("Sheet1")
   
5.         .Activate
   
6.         Set Rng = .Range("A2:A" & .Range("A2").End(xlDown).Row)  '設定Sheet1股票範圍
   
7.         If Application.Intersect(Rng, ActiveCell) Is Nothing Then  '沒有選擇到股票
   
8.             MsgBox "股票代號: 有誤"
   
9.             Exit Sub
   
10.         End If
    
11.         Set Rng = ActiveCell
    
12.         'Rng(1, 2) = Rng.Cells(1, 2)
    
13.         除息日 = Mid(Rng(1, 2), 1, 4) & "/" & Mid(Rng(1, 2), 5, 2) & "/" & Mid(Rng(1, 2), 7, 2)
    
14.     End With
    
15.     ReDim Ar(1, 0)
    
16.     With Sheets(Mid(Rng(1, 2), 1, 4))     '除息年度工作表
    
17.         Set 股票 = .Rows(1).Find(Rng, LOOKAT:=xlPart, LookIn:=xlValues)  '找到股票代號名稱 日報酬率欄位
    
18.         For Each R In .Range("A3:A" & .Range("A3").End(xlDown).Row)     '
    
19.             If R >= 除息日 And R <= 除息日 + 14 Then
    
20.                 Ar(0, i) = R
    
21.                 Ar(1, i) = R.Cells(1, 股票.Column)
    
22.                 i = i + 1
    
23.                 ReDim Preserve Ar(1, i)  '增加陣列的維數
    
24.             End If
    
25.         Next
    
26.     End With
    
27.     If i = 0 Then
    
28.         MsgBox "找不到" & 股票 & "日報酬率"
    
29.         Exit Sub
    
30.     End If
    
31.     With Sheets("Sheet2").Range("IV1").End(xlToLeft).Offset(, 1)  'Range("IV1")往左有資料的第一個儲存格->Offset(, 1) 向右移動一欄
    
32.         .Cells(1, 2) = 股票
    
33.         .Cells(2, 1) = "年月日"
    
34.         .Cells(2, 2) = "日報酬率"
    
35.         .Cells(3, 1).Resize(i, 2) = Application.WorksheetFunction.Transpose(Ar)
    
36.     End With
    
37.     End
    
38. End Sub

複製代碼

---

作者: candy516    時間: 2011-3-23 15:38

回復 2# GBKEE


    謝謝GBKEE 前輩願意幫我寫!^^誠心的謝謝謝你!
我試了一下無法將全部結果跑出來耶!
請問我應該將程式碼貼在哪一個Sheet中呢?
執行的時候有跳出一個MsgBox"股票代碼有誤"!
拜託您了!

---

作者: Hsieh    時間: 2011-3-23 16:50

本帖最後由 Hsieh 於 2011-3-23 16:56 編輯

回復 3# candy516

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Split(ky, ",")(1)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. If Not C Is Nothing Then
    
18.    Set B = .Rows(1).Find(Split(ky, ",")(0))
    
19.    Set B1 = .[A1:A2]
    
20.    Set B2 = B.Resize(2, 1)
    
21.    Set Rng = C.Resize(15, 1)
    
22.    Set Rng1 = .Cells(C.Row, B.Column).Resize(15, 1)
    
23.    With sht
    
24.       B1.Copy .Cells(r, k)
    
25.       B2.Copy .Cells(r, k + 1)
    
26.       Rng.Copy .Cells(r + 2, k)
    
27.       Rng1.Copy .Cells(r + 2, k + 1)
    
28.    End With
    
29.    k = IIf(k = 255, 1, k + 2)
    
30.    r = IIf(k = 1, r + 18, r)
    
31.    Else
    
32.    MsgBox "無此除權資料"
    
33. End If
    
34. End With
    
35. Next
    
36. Application.ScreenUpdating = True
    
37. End Sub

複製代碼

---

作者: candy516    時間: 2011-3-23 17:15

回復 4# Hsieh


謝謝Hsieh 前輩!
再跑出來的結果裡，第一筆資料是黑松是20100719~20100629，但我想要的結果是20100719~20100806~
請問我這樣需要改哪一個地方?我有試著更改，但無法跑出來。另外在請教一下，如果我接下的資料更改，像是把報酬率換成每股盈餘，
而我同樣是要用程式抓出除息日後14天得資料，是否把程式碼貼上即可!(資料格式一樣)
感謝您的幫忙!

---

作者: Hsieh    時間: 2011-3-23 17:39

回復 5# candy516
日期順序看錯，要往上15天才對
順便將無資料條件改一下

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Split(ky, ",")(1)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
18. If Not C Is Nothing And Not B Is Nothing Then
    
19. x = Application.Max(3, C.Row - 14)
    
20.    Set B1 = .[A1:A2]
    
21.    Set B2 = B.Resize(2, 1)
    
22.    Set Rng = .Cells(x, 1).Resize(15, 1)
    
23.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
    
24.    With sht
    
25.       B1.Copy .Cells(r, k)
    
26.       B2.Copy .Cells(r, k + 1)
    
27.       Rng.Copy .Cells(r + 2, k)
    
28.       Rng1.Copy .Cells(r + 2, k + 1)
    
29.    End With
    
30.    k = IIf(k = 255, 1, k + 2)
    
31.    r = IIf(k = 1, r + 18, r)
    
32.    Else
    
33.    MsgBox "無此除權資料"
    
34. End If
    
35. End With
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub

複製代碼

---

作者: GBKEE    時間: 2011-3-23 17:43

回復 3# candy516
傳檔來看看

---

作者: candy516    時間: 2011-3-23 18:17

回復 6# Hsieh


  請問Hsieh 前輩~
這兩次的程式碼差別最主要是"x = Application.Max(3, C.Row - 14)"嗎?代表意思是?!
如果我要改抓除息日後30日的報酬是不是將部分程式碼改掉即可?!
If Not C Is Nothing And Not B Is Nothing Then
x = Application.Max(3, C.Row - 14)
   Set B1 = .[A1:A2]
   Set B2 = B.Resize(2, 1)
   Set Rng = .Cells(x, 1).Resize(30, 1)
   Set Rng1 = .Cells(x, B.Column).Resize(30, 1)
   With sht
      B1.Copy .Cells(r, k)
      B2.Copy .Cells(r, k + 1)
      Rng.Copy .Cells(r + 2, k)
      Rng1.Copy .Cells(r + 2, k + 1)
   End With
   k = IIf(k = 255, 1, k + 2)
   r = IIf(k = 1, r + 33, r)
   Else
   MsgBox "無此除權資料"

謝謝您!

---

作者: candy516    時間: 2011-3-23 18:20

回復 7# GBKEE

謝謝前輩!^^

---

作者: Hsieh    時間: 2011-3-23 18:22

回復 8# candy516


    x = Application.Max(3, C.Row - 14)
是因為要算找到日期的位置往上14格的列號
若往上14格的列號只有<=3就要以3作為開始抓資料的列位
所以若你要抓30天資料這邊也要改
x = Application.Max(3, C.Row - 29)

---

作者: GBKEE    時間: 2011-3-23 18:33

回復 9# candy516
股票代號: 有誤
表示在Sheets("Sheet1") 沒有用滑鼠選定股票代號
你的檔案Sheets("Sheet1")是選在 A1  "證券代碼"
請在Sheets("Sheet1")的A欄  選定一家的 證券代碼 再試試

---

作者: candy516    時間: 2011-3-23 18:42

回復 11# GBKEE


成功了!
前輩您所寫的程式是不是只能單獨選一支股票?

---

作者: GBKEE    時間: 2011-3-23 18:48

回復 13# candy516
你1樓的訴求不是這樣?
還有其他想法說說看

---

作者: candy516    時間: 2011-3-23 18:52

回復 14# GBKEE


不好意思~是我表達的不過清楚!
我的訴求是要將十年每股的資料全部抓至一個新的SHEET中!
就像是Hsieh 前輩所寫的程式那樣!
Hsieh 前輩的程式也以幫我解決我的問題!
很謝謝您的幫忙~^^

---

作者: GBKEE    時間: 2011-3-23 19:49

回復 15# candy516
試試看是否一樣

1. Sub Ex()
   
2.     Dim 除息日 As Date, 股票 As Range, R As Range, Ar(), E As Integer, i As Integer, ii As Integer
   
3.     Sheets("Sheet2").Cells.Clear
   
4.     For E = 2 To Sheets("Sheet1").UsedRange.Rows.Count
   
5.         Set 股票 = Sheets("Sheet1").UsedRange.Rows(E).Cells(1)
   
6.         除息日 = Format(Sheets("Sheet1").UsedRange.Rows(E).Cells(2), "0000/00/00")
   
7.         ReDim Ar(1, 0)
   
8.         i = 0
   
9.         ii = 1
   
10.         With Sheets(Year(除息日) & "")
    
11.             Set 股票 = .Rows(1).Find(股票, LOOKAT:=xlPart, LookIn:=xlValues)  '找到股票代號名稱 日報酬率欄位
    
12.             For Each R In .Range("A3:A" & .Range("A3").End(xlDown).Row)     '
    
13.                 If R >= 除息日 And R <= 除息日 + 14 Then
    
14.                     Ar(0, i) = R
    
15.                     Ar(1, i) = R.Cells(1, 股票.Column)
    
16.                     i = i + 1
    
17.                     ReDim Preserve Ar(1, i)  '增加陣列的維數
    
18.                 End If
    
19.             Next
    
20.             If i > 0 Then
    
21.                 If Sheets("Sheet2").Range("IV" & ii).End(xlToLeft).Offset(, 1).Column >= Columns.Count - 1 Then ii = ii + 14
    
22.                 With Sheets("Sheet2").Range("IV" & ii).End(xlToLeft).Offset(, 1) 'Range("IV1")往左有資料的第一個儲存格->Offset(, 1) 向右移動一欄
    
23.                     .Cells(1, 2) = 股票
    
24.                     .Cells(2, 1) = "年月日"
    
25.                     .Cells(2, 2) = "日報酬率"
    
26.                     .Cells(3, 1).Resize(i, 2) = Application.WorksheetFunction.Transpose(Ar)
    
27.                 End With
    
28.             End If
    
29.         End With
    
30.     Next
    
31.     With Sheets("Sheet2")
    
32.         .Columns(1).Delete
    
33.         .Cells.EntireColumn.AutoFit
    
34.         .Cells.EntireRow.AutoFit
    
35.     End With
    
36. End Sub

複製代碼

---

作者: candy516    時間: 2011-3-23 20:17

回復 16# GBKEE


這樣就跟Hsieh 所寫的一樣了!
一樣的結果，有不同的寫法!
VBA真的是太厲害了!
我還需要時間來研究一下這些程式碼!
以便我日後可以更改所要抓取的資料!
前輩們真的都很厲害耶!
謝謝您唷!

---

作者: candy516    時間: 2011-3-26 16:02

回復 6# Hsieh


   請問前輩：
    如果我要將原本的結果改成附檔那樣的方式呈現，我應該改哪個地方的程式碼呢?(附檔的Sheet2)
是這個地方嗎?
      B1.Copy .Cells(r, k)
      B2.Copy .Cells(r, k + 1)
      Rng.Copy .Cells(r + 2, k)
      Rng1.Copy .Cells(r + 2, k + 1)
謝謝您!

---

作者: Hsieh    時間: 2011-3-26 16:33

回復 17# candy516

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Split(ky, ",")(1)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
18. If Not C Is Nothing And Not B Is Nothing Then
    
19. x = Application.Max(3, C.Row - 14)
    
20.    Set Rng = .Cells(x, 1).Resize(15, 1)
    
21.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
    
22.    With sht
    
23.       Rng.Copy .Cells(r, k)
    
24.       Rng1.Copy .Cells(r, k + 1)
    
25.       .Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
    
26.    End With
    
27.    r = r + 15
    
28.    Else
    
29.    MsgBox "無此除權資料"
    
30. End If
    
31. End With
    
32. Next
    
33. Application.ScreenUpdating = True
    
34. End Sub

複製代碼

---

作者: candy516    時間: 2011-3-26 16:49

回復 18# Hsieh


謝謝前輩!又幫我解決一個問題了!
真的非常感謝您!
^^

---

作者: candy516    時間: 2011-3-27 17:27

本帖最後由 candy516 於 2011-3-27 17:28 編輯

回復 18# Hsieh


前輩您好~
我將一樣的程式碼入另外一個檔案中執行，但卻不能跑出正確的結果!
像是檔案中的SHEET1裡的證券代碼2801他在2004年出現3次，但他跑出來只會出現一次!(執行結果如附檔的SHEET4)
如果我只想要跑出事件日後第五天的報酬率(包含事件日當天)，請問是要改哪裡呢?
不好意思一直麻煩您!= =
謝謝!

---

作者: Hsieh    時間: 2011-3-27 22:55

回復 20# candy516

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & A.Offset(, 1)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Left(Split(ky, ",")(1), 4)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
18. If Not C Is Nothing And Not B Is Nothing Then
    
19. x = Application.Max(3, C.Row - 5)
    
20.    Set Rng = .Cells(x, 1).Resize(5, 1)
    
21.    Set Rng1 = .Cells(x, B.Column).Resize(5, 1)
    
22.    With sht
    
23.       Rng.Copy .Cells(r, k)
    
24.       Rng1.Copy .Cells(r, k + 1)
    
25.       .Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
    
26.    End With
    
27.    r = r + 5
    
28.    Else
    
29.    MsgBox "無此除權資料"
    
30. End If
    
31. End With
    
32. Next
    
33. Application.ScreenUpdating = True
    
34. End Sub

複製代碼

---

作者: candy516    時間: 2011-3-28 00:12

回復 21# Hsieh


前輩您好：
我研究了這次得程式碼和之前的程式碼有何不同，發現不同之處在於
mystr = A & "," & A.Offset(, 1)d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
Next
End With
k = 1: r = 1
For Each ky In d.keys
y = Left(Split(ky, ",")(1), 4)
With Sheets(y)
請問Left(A.Offset(, 1), 4)有什麼差別呢?
再請問如果我只想要顯示事件日後第五天的報酬我應該怎麼改呢?
(舉例來說，事件日是20041119，則我要20041123的資料(t+4))
我試了好久還是不成功耶!= =
非常感謝!^^

---

作者: Hsieh    時間: 2011-3-28 08:30

回復 22# candy516


    可能有2種情況吧

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & A.Offset(, 1)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.       '若是直接用事件後第4天做搜尋值
    
11.       'd(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00")) + 4
    
12.    Next
    
13. End With
    
14. k = 1: r = 1
    
15. For Each ky In d.keys
    
16. y = Left(Split(ky, ",")(1), 4)
    
17. With Sheets(y)
    
18. Set C = .Columns("A").Find(d(ky))
    
19. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
20. If Not C Is Nothing And Not B Is Nothing Then
    
21. x = Application.Max(3, C.Row - 5)
    
22.    '用事件日向上4格為目標
    
23.    Set Rng = .Cells(x, 1)
    
24.    Set Rng1 = .Cells(x, B.Column)
    
25.    '直接用事件後第4天做搜尋值
    
26.    'Set Rng = .Cells(C.Row, 1)
    
27.    'Set Rng1 = .Cells(C.Row, B.Column)
    
28. 
    
29.    With sht
    
30.       Rng.Copy .Cells(r, k)
    
31.       Rng1.Copy .Cells(r, k + 1)
    
32.       .Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
    
33.    End With
    
34.    r = r + 1 '只有一天資料所以只要加1
    
35.    Else
    
36.    MsgBox "無" & y & "年" & Split(ky, ",")(0) & "事件資料"
    
37. End If
    
38. End With
    
39. Next
    
40. Application.ScreenUpdating = True
    
41. End Sub

複製代碼

---

作者: candy516    時間: 2011-3-29 18:16

回復 23# Hsieh


謝謝前輩的解說!
前輩所寫的程式碼真的幫我很大的忙，
我現在可以自由的更改我想要抓取的欄位!
或者是特定哪一天的資料!
真的很感謝您!^^
謝謝!

---

作者: candy516    時間: 2011-3-30 01:20

回復 23# Hsieh


   
前輩您好~
我現在又回歸到本主題一開始的程式碼，
我現在換篩選出沒填權股票的報酬率，我將檔案下載成一樣的格式，
但貼上程式碼執行後，它說型態不符!
請問是哪裡出了問題!?
我是用以下的程式碼!

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Split(ky, ",")(1)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
18. If Not C Is Nothing And Not B Is Nothing Then
    
19. x = Application.Max(3, C.Row - 14)
    
20.    Set Rng = .Cells(x, 1).Resize(15, 1)
    
21.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
    
22.    With sht
    
23.       Rng.Copy .Cells(r, k)
    
24.       Rng1.Copy .Cells(r, k + 1)
    
25.       .Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
    
26.    End With
    
27.    r = r + 15
    
28.    Else
    
29.    MsgBox "無此除權資料"
    
30. End If
    
31. End With
    
32. Next
    
33. Application.ScreenUpdating = True
    
34. End Sub

複製代碼

(因為資料檔案太大，所以我先刪除其他九年的資料，只剩2010)

謝謝您!^^

---

作者: Hsieh    時間: 2011-3-30 12:42

回復 25# candy516

1. Sub ex()
   
2. On Error Resume Next
   
3. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set sht = Sheets.Add(after:=Sheets(1))
   
6. Application.ScreenUpdating = False
   
7. With Sheet1
   
8.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
9.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
10.      '你Sheet1的A欄是以日期格式yyyy/m/d輸入，但格式設成yyyymmdd，所以，造成非全部為8碼
    
11.    '用TEXT屬性得到所見字串
    
12.       d(mystr) = DateValue(Format(A.Offset(, 1).Text, "0000/00/00"))
    
13.       If Err.Number <> 0 Then MsgBox A & A.Offset(, 1)
    
14.    Next
    
15. End With
    
16. k = 1: r = 1
    
17. For Each ky In d.keys
    
18. y = Split(ky, ",")(1)
    
19. With Sheets(y)
    
20. Set C = .Columns("A").Find(d(ky))
    
21. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
22. If Not C Is Nothing And Not B Is Nothing Then
    
23. x = Application.Max(3, C.Row - 14)
    
24.    Set Rng = .Cells(x, 1).Resize(15, 1)
    
25.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
    
26.    With sht
    
27.       Rng.Copy .Cells(r, k)
    
28.       Rng1.Copy .Cells(r, k + 1)
    
29.       .Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
    
30.    End With
    
31.    r = r + 15
    
32.    Else
    
33.    MsgBox "無此除權資料"
    
34. End If
    
35. End With
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub

複製代碼

---

作者: candy516    時間: 2011-3-30 14:54

回復 26# Hsieh


我也是想說是那邊的問題,我也做過修改!= =
但沒有成功， 所以是只要把格式改掉即可，對吧!
謝謝您唷!^^

---

作者: candy516    時間: 2011-3-31 01:45

回復 26# Hsieh


前輩您好：
    在附檔裡的SHEET1中，A5證券代碼為3009，我是想要抓出20050103後五天(含當天)，
所以正確應該抓取的資料為2005/1/7  -7.7104，但程式跑出來變成2005/11/9  7.402!
我研究一下發現，只要原始資料是1、2月的都是不對的耶!
又要麻煩您幫我解答一下，不好意思!
謝謝您!^^

---

作者: Hsieh    時間: 2011-3-31 18:32

回復 28# candy516

正規化表格是根本解決之道
不過得要先擦完屁股喔

至於程式問題點是出在
Set C = .Columns("A").Find(d(ky), lookat:=xlWhole)
Set B = .Rows(1).Find(Split(ky, ",")(0), lookat:=xlPart)
加入搜尋參數就能正確找到資料了

---

作者: candy516    時間: 2011-3-31 19:06

前輩們好~
正規化是指將這些資料表單把整理成一定的格式嗎?是讓資料更有秩序嗎?!
所以說正規化是也需要用程式碼來執行還是說像是樞紐分析之類的嗎?
另外一問，“擦屁股”是什麼意思?
謝謝~^^

---

作者: candy516    時間: 2011-3-31 19:07

回復 31# Hsieh


終於解決這個問題了!= =
謝謝前輩~

---

作者: Hsieh    時間: 2011-3-31 23:57

回復 32# candy516

假如你這些資料是從系統中或網路Download的
這已經是既成表格，但是這樣的資料排列在資料庫原則中牴觸了一列為一筆資料的原則
這樣的表格你無法使用EXCEL內建的篩選功能或樞紐分析表
老夏前輩的檔案中你會發現是將所有年度的資料
依照日期、股票名稱、價格
一筆一筆地在同一工作表中呈現
這樣你就很輕易地使用樞紐分析或是以篩選功能獲得想要的資料
所以要把你的表格整理成跟老夏前輩一樣的資料表
你覺得你要花多少時間跟體力才能完成
所以，如果你是逐筆資料KEY的建立資料表時
那麼直接做成老夏前輩的格式，是不是就可以少掉這個整理程序
這就是我所說擦屁股啦!
老夏前輩不知道擦好沒?他說還在努力待續呢

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)