[开_23] 格式、找尋及 merge cell ★★ (已完結)

Emily

各位請保留 A9:AE10 的格式

shuyee

Sub test() Dim i%, BegCol%, HolDay(22) As Date, tmpR As Range [c1] = "24 Jan 2005" [c4] = DateAdd("d", 28, [c1]) BegCol = [d4].Column Range(Cells(6, BegCol), Cells(40, BegCol + 28)).Interior.ColorIndex = xlNone Range(Cells(41, BegCol), Cells(41, BegCol + 28)).ClearContents Range(Cells(4, BegCol), Cells(4, BegCol + 28)).MergeCells = False For i = 1 To 22 HolDay(i) = Sheets("PH").Cells(1 + i, 1) If HolDay(i) > [c4] Then Exit For Next For BegCol = 1 To i - 1 If HolDay(BegCol) >= [c1] And HolDay(BegCol) <= [c4] Then Cells(41, [d4].Column + (HolDay(BegCol) - [c1])) = Sheets("PH").Cells(1 + BegCol, 3).Value End If Next [c4] = DateSerial(Year([c1]), Month([c1]) + 1, 0) i = [c4] - [c1] [d4] = [c1] [d4].HorizontalAlignment = xlCenter [d4].NumberFormatLocal = "mmm" BegCol = [d4].Column Range([d4], Cells(4, BegCol + i)).Merge Cells(4, BegCol + i + 1) = [c4] + 1 Cells(4, BegCol + i + 1).HorizontalAlignment = xlCenter Cells(4, BegCol + i + 1).NumberFormat = "mmm" Set tmpR = Range(Cells(4, BegCol + i + 1), Cells(4, BegCol + 28)) tmpR.Merge With tmpR.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 5 End With [d5] = DatePart("ww", [c1]) For i = 1 To 3 Cells(5, BegCol + i * 7) = [d5] + i Next For ii% = 1 To 28 i = BegCol + ii% - 1 If ii% Mod 7 = 0 Or Len(Cells(41, i)) > 0 Then Range(Cells(6, i), Cells(40, i)).Interior.ColorIndex = 20 End If Next End Sub 出现这样的提示是因为合并时,其它单元格有内容,初始化时把它们清了就行了.这是上面程序的第7句,在其下加一句.

Range(Cells(4, BegCol), Cells(4, BegCol + 28)).MergeCells = False

增加的语句是:

Range(Cells(4, BegCol), Cells(4, BegCol + 28)).ClearContents

[此贴子已经被作者于2005-6-22 10:03:26编辑过]

Emily

shuyee

多謝你的參予，但有下列問題，請更改

Emily

請問各板友對以上的作法有什麼意見，如沒有則取消置頂。問題依然保留，希望各位可試用 find

Emily

以下是引用办公之星在2005-5-26 11:42:00的发言：

版主大约不在大陆生活，繁体不算，汉语也不怎么“协议”，呵呵。

其實我很多時都不明白內地朋友的意思

Emily

這測試題是從多年前寫下的輪值表抽取一部份，我覺得 Samsea 寫的比較好。

上傳的檔案原本已有一些簡單公式，參予的朋友全部沒有保留，反而用 VBA 取代。D9 - AE10 不用改變。

在函數公式而言，其實只要更改 C1 的日期，D9 - AE9 已立即更新，比用 VBA快。

請參看附件 OTcXNlxv.zip (23.81 KB, 下载次数: 80)

2005-6-24 23:49 上传

点击文件名下载附件
[VBA1] 格式、找尋及 merge cell ★★