篩選資料並且放到新的Sheet裡 - Excel程式區

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

3^# 跳轉到 »

發表於 2011-3-23 15:38 | 只看該作者

回復 2# GBKEE

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2011-3-23 08:57 | 只看該作者

回復 1# candy516
試試看

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

複製代碼

靜思自在 : 不怕事多，只怕多事。