[求助]如何篩選較佳

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

1^# 跳轉到 »

發表於 2012-2-11 21:24 | 顯示全部帖子

本帖最後由 GBKEE 於 2012-2-16 08:20 編輯

回復 1# baa168
試試看

Option Explicit
Sub Ex()
Dim xR As Integer, xMonth As Integer, Ar(), xAr As Integer
xR = 4 '第4列
ReDim Ar(1, xAr) '重新宣告 AR(0 TO 1,0) 二維陣列
Ar(0, xAr) = "日期" 'Ar(0, 0) = "日期"
Ar(1, xAr) = "內容" 'Ar(1, 0) = "內容"
With ActiveSheet
xMonth = Month(.Cells(xR, "A")) '取得 A4月份
Do While .Cells(xR, "A") <> "" '執行迴圈條件不是空白的儲存格
If Month(.Cells(xR + 1, "A")) <> xMonth Or .Cells(xR + 1, "A") = "" Then
'下一列的月份<>這一列的月份或是下一列是空白
xMonth = Month(.Cells(xR + 1, "A")) '更改月份的數值
xAr = xAr + 1 '二維陣列的第二維再加一個元素
ReDim Preserve Ar(1, xAr) '重新宣告 AR(0 TO 1,xAr) 二維陣列
'Preserve 選擇性引數。當改變原有陣列最後一維的大小時，仍然保有原來的資料的關鍵字。
Ar(0, xAr) = .Cells(xR, "A") 'Ar(0, xAr) = "日期"
Ar(1, xAr) = .Cells(xR, "B") 'Ar(0, xAr) = "內容"
End If
xR = xR + 1 '再往下一列
Loop
.Range("G3").CurrentRegion = "" 'CurrentRegion 屬性目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀。
.Range("G3").Resize(xAr + 1, 2) = Application.Transpose(Ar) '運用工作表函數 Transpose (轉置) Ar 陣列
.Range("G3").Resize(xAr + 1).NumberFormatLocal = "m/d;@" ' 制訂儲存格日期格式
End With
End Sub

複製代碼

靜思自在 : 對父母要知恩，感恩、報恩。