- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-10-21
|
謝謝論壇,謝謝各位前輩
後學藉此帖學習前輩的方案,變更不同需求情境,學習方案如下,請各位前輩指教
表1 資料表:
准提部林前輩的精簡方案執行結果:
後學方案執行結果:
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 |
|
發表於 2023-6-13 09:16
| 