返回列表 上一主題 發帖

請問自動換行格式要如何拆分兩行 公式及VBA做法?

Andy2483
　暱稱: 厚臉皮的學生

碩士班Rank: 5Rank: 5

帖子
1567 
主題
40 
精華
0 
積分
1591 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
100 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2026-2-2 
1# 跳轉到 »
發表於 2024-2-26 09:05 | 顯示全部帖子
回復 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.[D2], xS.[A65536])
ReDim Crr(1 To UBound(Brr), 1 To 6)
For i = 1 To UBound(Brr)
   If Trim(Brr(i, 2)) = "" Then GoTo i01 Else R = R + 1
   If InStr(Brr(i, 3), vbLf) Then
      If xU Is Nothing Then
         Set xU = Sheets("整理").Cells(R + 1, 6)
         Else
         Set xU = Union(xU, Sheets("整理").Cells(R + 1, 6))
      End If
   End If
   Crr(R, 1) = R
   Crr(R, 2) = Trim(Brr(i, 1))
   Crr(R, 3) = Trim(Brr(i, 2))
   Crr(R, 4) = Trim(Split(Brr(i, 3) & vbLf, vbLf)(0))
   Crr(R, 5) = Val(Brr(i, 4))
   Crr(R, 6) = Mid(Trim(Brr(i, 3)), InStr(Trim(Brr(i, 3)), vbLf) + 1)
i01: Next
If R = 0 Then MsgBox "沒有資料": Exit Sub
With [整理!A2].Resize(R, 6)
   .Value = Crr
   .Borders.LineStyle = xlContinuous
End With
If Not xU Is Nothing Then xU.Font.ColorIndex = 3
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

碩士班Rank: 5Rank: 5

帖子
1567 
主題
40 
精華
0 
積分
1591 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
100 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2026-2-2 
2#
發表於 2024-2-26 13:49 | 顯示全部帖子
回復  Andy2483

真的很感謝您
aassddff736 發表於 2024-2-26 11:35

Option Explicit
Sub 排成表彙整為整理表()
Dim Brr, Crr, i&, R&, xU As Range, xS As Worksheet
Set xS = Sheets("排程")
'↑令xS變數是 "排程"工作表
[整理!A1].CurrentRegion.Offset(1).EntireRow.Delete
'↑令"整理"表留下標題列,其它列刪除
Brr = Range(xS.[D2], xS.[A65536])
'↑令Brr變數是二維陣列,以儲存格值帶入陣列中
ReDim Crr(1 To UBound(Brr), 1 To 6)
'↑宣告Crr變數是二維空陣列,宣告上下 左右範圍
For i = 1 To UBound(Brr)
'↑設順迴圈!i從1到 Brr陣列最大索引列號
   If Trim(Brr(i, 2)) = "" Then GoTo i01 Else R = R + 1
   '↑如果關鍵欄空格就略過,否則就令R變數累加1
   Crr(R, 1) = R
   Crr(R, 2) = Trim(Brr(i, 1))
   Crr(R, 3) = Trim(Brr(i, 2))
   Crr(R, 4) = Trim(Split(Brr(i, 3) & vbLf, vbLf)(0))
   Crr(R, 5) = Val(Brr(i, 4))
   Crr(R, 6) = Mid(Trim(Brr(i, 3)), InStr(Trim(Brr(i, 3)), vbLf) + 1)
   '↑將Brr陣列值寫入Crr陣列中
i01: Next
If R = 0 Then MsgBox "沒有資料": Exit Sub
With [整理!A2].Resize(R, 6)
   .Value = Crr
   '↑將Crr陣列值寫入儲存格中
   .Borders.LineStyle = xlContinuous
   '↑設定格線
End With
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

        靜思自在 : 得理要饒人，理直要氣和。
返回列表 上一主題