ToB企服应用市场:ToB评测及商务社交产业平台

标题: 【EXCEL 向下合并制定列的空缺内容】 [打印本页]

---

作者: 科技颠覆者    时间: 2025-1-10 16:17
标题: 【EXCEL 向下合并制定列的空缺内容】
alt + F11 开始编写VBA脚本
alt + F8 实行 选中MergeAndFillDownWithoutReMerge 实行合并

1. Sub MergeAndFillDownWithoutReMerge()
2.     Dim ws As Worksheet
3.     Dim cell As Range
4.     Dim lastRow As Long, currentRow As Long
5.     Dim startCell As Range, mergeRange As Range
6.    
7.     ' 设置工作表
8.     Set ws = ActiveSheet
9.    
10.     ' 获取选中列的最后一行
11.     lastRow = ws.Cells(ws.Rows.Count, Selection.Column).End(xlUp).Row
12.    
13.     ' 从下往上遍历选中的列以避免合并后影响后续判断
14.     For currentRow = lastRow To 1 Step -1
15.         Set cell = ws.Cells(currentRow, Selection.Column)
16.         
17.         ' 检查当前单元格是否已被合并
18.         If Not cell.MergeCells Then
19.             If IsEmpty(cell.Value) Then
20.                 ' 找到第一个非空的上一个单元格
21.                 Set startCell = cell.End(xlUp)
22.                
23.                 ' 如果startCell不是cell本身（即cell不是第一行）并且未被合并
24.                 If Not startCell.Address = cell.Address And Not startCell.MergeCells Then
25.                     ' 创建合并范围
26.                     Set mergeRange = ws.Range(startCell, cell)
27.                     
28.                     ' 填充空白单元格
29.                     startCell.Copy
30.                     mergeRange.PasteSpecial Paste:=xlPasteAll
31.                     
32.                     ' 合并单元格
33.                     With mergeRange
34.                         .Merge
35.                         .VerticalAlignment = xlCenter
36.                         .HorizontalAlignment = xlCenter
37.                     End With
38.                 End If
39.             End If
40.         End If
41.     Next currentRow
42.    
43.     ' 清除剪贴板
44.     Application.CutCopyMode = False
45. End Sub

复制代码

免责声明：如果侵犯了您的权益，请联系站长，我们会及时删除侵权内容，谢谢合作！更多信息从访问主页：qidao123.com:ToB企服之家，中国第一个企服评测及商务社交产业平台。

---

欢迎光临 ToB企服应用市场:ToB评测及商务社交产业平台 (https://dis.qidao123.com/)

Powered by Discuz! X3.4