麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
Sub Ex()
Dim Sh(1 To 2) As Worksheet, Rng(1 To 3) As Range, CRng(1 To 2) As Range
Dim i As Integer, R As Integer, C As Integer
Set Sh(1) = Sheets("Sheet1") '資料表
Set Sh(2) = Sheets("Sheet2") '呈現表
Set Rng(1) = Sh(1).Range("i3:j3") '課程起日~課程迄日
Set Rng(2) = Sh(2).Range("c4") '排程開始日期
Set CRng(1) = Sh(1).Range("M2:S2") '上課星期
Set CRng(2) = Sh(2).Range("b5", Sh(2).Range("b5").End(xlDown)) '上課時間
Rng(2).Offset(1).Resize(CRng(2).Rows.Count, 7) = "" '清除呈現表
Do While Rng(1).Cells(1) <> "" '課程起日<>""
i = 0 '排程開始日期的欄位
Do While Rng(2).Offset(, i) >= Rng(1).Cells(1) And Rng(2).Offset(, i) <= Rng(1).Cells(2)
'迴圈的條件:呈現表的日期是[課程起日~課程迄日]的期間
C = CRng(1).Cells(Application.Match(Format(Rng(2).Offset(, i), "AAAA"), CRng(1), 0)).Column
'C = 資料表的上課星期中搜尋,排程日期的星期欄數
Set Rng(3) = Sh(1).Cells(Rng(1).Row, C) '資料表的上課的時間區段
If Rng(3) <> "" Then
R = Application.Match(Rng(3), CRng(2), 1)
'R=列數:呈現表的上課的時間中所對應的,資料表的上課的時間
Rng(2).Offset(R, i) = IIf(Rng(2).Offset(R, i) = "", Sh(1).Cells(Rng(1).Row, "B"), Rng(2).Offset(R, i) & vbLf & Sh(1).Cells(Rng(1).Row, "B"))
'排程開始日期(R列, i欄)
'Sh(1).Cells(Rng(1).Row, "B") =>資料表的學員編號
End If
i = i + 1 'Rng(2).Offset(, i)->排程開始日期的欄位,向右移動一欄
Loop
Set Rng(1) = Rng(1).Offset(1) '課程起日,向下移動一列
Loop
CRng(2).EntireRow.AutoFit
End Sub

複製代碼