|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
参与一下。。。- Sub ykcbf() '//2023.12.24
- Dim arr, brr
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- r = Cells(Rows.Count, 1).End(3).Row
- [f:j].UnMerge
- [h2:j10000] = ""
- arr = Range("a2:c" & r)
- ReDim brr(1 To UBound(arr) * 4, 1 To 5)
- For i = 1 To UBound(arr)
- m = m + 2
- brr(m - 1, 1) = arr(i, 1)
- brr(m, 1) = arr(i, 1)
- brr(m - 1, 5) = arr(i, 2)
- brr(m, 5) = arr(i, 2)
- m = m + 2
- brr(m - 1, 1) = arr(i, 1)
- brr(m, 1) = arr(i, 1)
- brr(m - 1, 5) = arr(i, 3)
- brr(m, 5) = arr(i, 3)
- Next
- [f2].Resize(m, 5) = brr
- r = Cells(Rows.Count, "f").End(3).Row
- For i = r To 2 Step -1
- Set Rng = Cells(i, "f")
- Set Rng1 = Rng.Offset(-1)
- If Rng = Rng1 Then
- Rng1.Resize(2).Merge
- End If
- Set Rng = Cells(i, "j")
- Set Rng1 = Rng.Offset(-1)
- If Rng = Rng1 Then
- Rng1.Resize(2).Merge
- End If
- Next
- Application.ScreenUpdating = True
- MsgBox "OK!"
- End Sub
复制代码
|
|