自訂函數:
Function GetItem(xA As Range, xB As Range) As String
Dim xR As Range, N%, TT$
For Each xR In xB
N = N + 1
If Val(xR) > 0 Then TT = TT & "、" & xA(N)
Next
GetItem = Mid(TT, 2)
End Function
若資料多, 直接用vba取出相關資料:
Sub GetDateItem()
Dim Arr, i&, j%, N&, T$
[工作表2!A:B].ClearContents
[工作表2!A1:B1] = Array("日期", "施工項目")
Arr = Range([工作表1!H1], [工作表1!A65536].End(xlUp))
For i = 6 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 101
For j = 2 To UBound(Arr, 2)
If Val(Arr(i, j)) <> 0 Then T = T & "、" & Arr(1, j)
Next j
If T = "" Then GoTo 101
N = N + 1
Arr(N, 1) = Arr(i, 1): Arr(N, 2) = Mid(T, 2): T = ""
101: Next i
If N > 0 Then [工作表2!A2:B2].Resize(N) = Arr
Application.Goto [工作表2!A1]
End Sub
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
