Option Explicit
Sub TEST()
Dim Brr, Z, i&, j%, sR As Range, eR As Range, xR As Range
With ActiveSheet.UsedRange
Intersect(.Offset(0, 7), .Offset(4, 0)).Delete Shift:=xlUp
End With
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([A1], [C5].End(xlDown)(2, 2))
For i = 1 To UBound(Brr)
If Trim(Brr(i, 1)) <> "" Or i = UBound(Brr) Then
Set sR = eR: Set eR = Cells(i, 1)
If Not sR Is Nothing Then
Z(sR & "") = Range(sR(1, 2), eR(0, 4))
Z(sR & "/r") = eR.Row - sR.Row
End If
End If
Next
Brr = Range([C35], [B65536].End(xlUp)): Set xR = [H5]
For i = 1 To UBound(Brr)
If Brr(i, 2) = "是" Then
With xR.Resize(Z(Brr(i, 1) & "/r"), 3)
.Value = Z(Brr(i, 1))
.Rows(1).Font.Bold = True
For j = 7 To 10: .Borders(j).Weight = 4: Next
End With
Set xR = xR(Z(Brr(i, 1) & "/r") + 1, 1)
End If
Next
End Sub
'==========================================================
以下是組別也帶入的方案
執行前: 執行結果:
[attach]37189[/attach] [attach]37190[/attach]
Option Explicit
Sub TEST()
Dim 資料陣列, 到勤控制陣列, 字典, i&, j%, 起始格 As Range, 結束格 As Range, 結果起始格 As Range
With ActiveSheet.UsedRange
Intersect(.Offset(0, 7), .Offset(4, 0)).Delete Shift:=xlUp
End With
Set 字典 = CreateObject("Scripting.Dictionary")
資料陣列 = Range([A1], [C5].End(xlDown)(2, 2))
For i = 1 To UBound(資料陣列)
If Trim(資料陣列(i, 1)) <> "" Or i = UBound(資料陣列) Then
Set 起始格 = 結束格: Set 結束格 = Cells(i, 1)
If Not 起始格 Is Nothing Then
字典(起始格 & "") = Range(起始格(1, 1), 結束格(0, 4))
字典(起始格 & "/r") = 結束格.Row - 起始格.Row
End If
End If
Next
到勤控制陣列 = Range([C35], [B65536].End(xlUp)): Set 結果起始格 = [H5]
For i = 1 To UBound(到勤控制陣列)
If 到勤控制陣列(i, 2) = "是" Then
With 結果起始格.Resize(字典(到勤控制陣列(i, 1) & "/r"), 4)
.Value = 字典(到勤控制陣列(i, 1))
.Rows(1).Font.Bold = True
.Columns(1).Merge
For j = 7 To 10: .Borders(j).Weight = 4: Next
End With
Set 結果起始格 = 結果起始格(字典(到勤控制陣列(i, 1) & "/r") + 1, 1)
End If
Next
End Sub作者: hcm19522 時間: 2023-12-27 14:26