|
![](https://clubstatic.excelhome.net/image/common/ico_lz.png)
楼主 |
发表于 2024-7-8 19:45
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
谢谢解答。
- Sub Macro1()
- Application.DisplayAlerts = False
- Dim Sht As Worksheet, Sht1 As Worksheet
- Set Sht = Sheet1
- Set Sht1 = Sheet6
- Dim Rng As Range, oRng As Range
- Dim Str As String
- Dim ii: ii = 1
- With Sht1
- Set Rng = .Cells(10, 1).CurrentRegion
- 'Debug.Print Rng.Address
- End With
- ''
- With Sht
- .Cells.Clear
- .Activate
- Rng.Copy
- .Cells(5, 1).PasteSpecial xlPasteAll
-
- Set Rng = .Cells(20, 1).CurrentRegion
- Rng.Select
- End With
- Rng.Sort key1:=Rng(, 4), Order1:=xlAscending 'xlDescending
-
- ''
- For jj = 1 To 3
- MergeRng Rng(, jj).Resize(Rng.Rows.Count, 1)
- Next jj
- With Rng.Borders
- .LineStyle = 1
- .Weight = 3
- End With
-
- Application.DisplayAlerts = True
- End Sub
- Function MergeRng(Rng As Range)
- Dim LastRow, FirstRow
- Dim ii, jj
- Dim Sht As Worksheet
- Set Sht = Rng.Parent
- With Rng.Parent
- LastRow = Rng.Row + Rng.Rows.Count - 1
- For ii = Rng.Row + Rng.Rows.Count - 1 To 2 Step -1
- If .Cells(ii, Rng.Column).Value <> .Cells(ii - 1, Rng.Column).Value Then
- FirstRow = ii
- .Cells(FirstRow, Rng.Column).Resize(LastRow - FirstRow + 1, 1).Merge
- LastRow = ii - 1
- End If
- Next ii
- End With
- End Function
复制代码
|
|