[發問] 篩選資料並且放到新的Sheet裡

candy516

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

GBKEE

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

回復 2# GBKEE


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

Hsieh

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

回復 4# Hsieh


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

Hsieh

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

回復 3# candy516
傳檔來看看

candy516

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

回復 7# GBKEE

謝謝前輩!^^

Hsieh

回復 8# candy516


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