Sub TEST()
Dim R&, x&, y&, T$, xR As Range, xH As Range
[Sheet2!A:C].ClearContents
Set xH = [Sheet2!A1]
xH.Resize(1, 3) = Array("樓層", "序", "姓名")
R = Sheets("Sheet1").UsedRange.Rows.Count
For x = 2 To 14 Step 6
For y = 4 To R
Set xR = [Sheet1!A1].Cells(y, x)
If xR = 1 Then T = xR(1, 0) & ""
If xR(1, 3) = "#" Or xR(1, 4) = "#" Then
Set xH = xH(2)
xH.Resize(1, 3) = Array(T, xR, xR(1, 2))
End If
Next y
Next x
End Sub作者: shan0948 時間: 2015-11-6 22:21
Option Explicit
Sub TEST()
Dim Brr, i&, j%, R&, xA, xAs
Sheets(2).[A:C].Delete: Brr = Sheets(1).UsedRange
For j = 5 To 17 Step 6
For i = 4 To UBound(Brr)
If InStr(Brr(i, j - 1) & Brr(i, j), "#") Then
R = R + 1
Brr(R, 1) = Sheets(1).Cells(i, j).Item(1, -3).MergeArea(1)
Brr(R, 2) = Brr(i, j - 3): Brr(R, 3) = Brr(i, j - 2)
End If
Next
Next
If R = 0 Then Exit Sub Else xAs = Array([{"樓層", "序", "姓名"}], Brr)
xA = Array(Sheets(2).[A1].Resize(, 3), Sheets(2).[A2].Resize(R, 3))
For i = 0 To UBound(xA)
xA(i).Value = xAs(i): xA(i).Borders.LineStyle = 1
For j = 7 To 10: xA(i).Borders(j).Weight = 4: Next
Next
Application.Goto Sheets(2).[A1]
End Sub作者: shan0948 時間: 2024-1-12 19:50