- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-12-5
|
2#
發表於 2024-2-26 08:21
| 只看該作者
回復 1# aassddff736
謝謝前輩發表此主題與範例
後學藉此帖練習陣列,學習方案如下,請前輩參考
"排成"表 執行前:
"排成"表 執行結果:
Option Explicit
Sub 整理表彙整為排成表()
Dim Brr, Crr, i&, R&, xU As Range, xS As Worksheet
Set xS = Sheets("整理")
[排成!A1].CurrentRegion.Offset(1).EntireRow.Delete
Brr = Range(xS.[F2], xS.[A65536])
ReDim Crr(1 To UBound(Brr), 1 To 4)
For i = 1 To UBound(Brr)
If Trim(Brr(i, 3)) = "" Then GoTo i01 Else R = R + 1
If Trim(Brr(i, 6)) <> "" Then
If xU Is Nothing Then
Set xU = Sheets("排成").Cells(R + 1, 3)
Else
Set xU = Union(xU, Sheets("排成").Cells(R + 1, 3))
End If
End If
Crr(R, 1) = Trim(Brr(i, 2))
Crr(R, 2) = Trim(Brr(i, 3))
Crr(R, 3) = Trim(Brr(i, 4)) & vbCrLf & Trim(Brr(i, 6))
Crr(R, 4) = Val(Brr(i, 5))
i01: Next
If R = 0 Then MsgBox "沒有資料": Exit Sub
With [排成!A2].Resize(R, 4)
.Value = Crr
.Borders.LineStyle = xlContinuous
End With
If Not xU Is Nothing Then xU.Font.ColorIndex = 3
End Sub |
|
