Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖學習前輩的方案,變更不同需求情境,學習方案如下,請各位前輩指教

表1 資料表:

下載 (143.42 KB)

2023-6-13 09:13

准提部林前輩的精簡方案執行結果:

下載 (69.73 KB)

2023-6-13 09:14

後學方案執行結果:

下載 (141.91 KB)

2023-6-13 09:14

Option Explicit
Sub TEST()
Dim Brr, Crr, i&, j%, R&, Y&, X%, T$
Dim xR As Range, Sh1 As Worksheet, Sh2 As Worksheet
'↑宣告變數
Set Sh1 = Sheets("工作表1"): Set Sh2 = Sheets("工作表2")
'↑令變數盛裝物件(工作表)
Sh2.UsedRange.ClearContents
'↑令表2有使用儲存格清除內容
Brr = Range(Sh1.[H1], Sh1.Cells(Rows.Count, "A").End(xlUp))
'↑令Brr變數是二維陣列,以表1的A~H欄陣列值帶入陣列中
Y = UBound(Brr): X = UBound(Brr, 2)
'↑令Y變數是 Brr陣列縱向最大索引列號,令X變數是 Brr陣列橫向最大索引欄號
ReDim Crr(1 To Y, 1 To 2)
'↑令Crr變數是 二維空陣列,縱向範圍同Brr陣列,橫向1~2欄
For i = 6 To Y
'↑設順迴圈
   If i = 6 Then
      Crr(1, 1) = "日期"
      Crr(1, 2) = "施工項目"
      R = 1
   End If
   '↑如果i變數是1,先處理標題列
   If Not IsDate(Brr(i, 1)) Then
   '↑如果Brr陣列標題欄(日期欄)裡的值不是日期?
      MsgBox Brr(i, 1) & " 是錯誤的日期!請修正後再重新執行"
      '↑跳出提示窗 "~~~"
      Exit Sub
      '↑結束程式執行
   End If
   For j = 2 To X
      If Val(Brr(i, j)) > 0 Then T = T & "、" & Brr(1, j)
   Next
   '↑設順迴圈,將同列各欄是數值的標題以頓號間隔
   R = R + 1
   '↑令R變數累加1
   Crr(R, 1) = Brr(i, 1)
   If T <> "" Then
   '↑如果T變數不是空的?
      Crr(R, 2) = Mid(T, 2)
      '↑令Crr陣列第2欄寫入施工項目集字串
      T = ""
      '↑令T變數清除內容
   End If
i01: Next
Sh2.[A1].Resize(R, 2) = Crr
'↑令表2.[A1]擴展範圍儲存格值以Crr陣列值寫入
Application.Goto Sh2.[A1]
'↑令游標跳到表2.[A1]儲存格
Set Sh1 = Nothing: Set Sh2 = Nothing: Erase Brr, Crr
'↑令釋放變數
End Sub