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

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

1^# 跳轉到 »

發表於 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

複製代碼

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

2^#

發表於 2011-3-23 17:43 | 顯示全部帖子

回復 3# candy516
傳檔來看看

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

3^#

發表於 2011-3-23 18:33 | 顯示全部帖子

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

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

4^#

發表於 2011-3-23 18:48 | 顯示全部帖子

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

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

5^#

發表於 2011-3-23 19:49 | 顯示全部帖子

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

Sub Ex()
Dim 除息日 As Date, 股票 As Range, R As Range, Ar(), E As Integer, i As Integer, ii As Integer
Sheets("Sheet2").Cells.Clear
For E = 2 To Sheets("Sheet1").UsedRange.Rows.Count
Set 股票 = Sheets("Sheet1").UsedRange.Rows(E).Cells(1)
除息日 = Format(Sheets("Sheet1").UsedRange.Rows(E).Cells(2), "0000/00/00")
ReDim Ar(1, 0)
i = 0
ii = 1
With Sheets(Year(除息日) & "")
Set 股票 = .Rows(1).Find(股票, 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
If i > 0 Then
If Sheets("Sheet2").Range("IV" & ii).End(xlToLeft).Offset(, 1).Column >= Columns.Count - 1 Then ii = ii + 14
With Sheets("Sheet2").Range("IV" & ii).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 If
End With
Next
With Sheets("Sheet2")
.Columns(1).Delete
.Cells.EntireColumn.AutoFit
.Cells.EntireRow.AutoFit
End With
End Sub

複製代碼

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