请教左行数据如何按右侧排列？

左广恒

移动数据（有合并单元格）.zip (8.6 KB, 下载次数: 9)

2023-12-24 15:57 上传

点击文件名下载附件

gwjkkkkk

请参考附件。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2023.12.24
   
2.     Dim arr, brr
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     r = Cells(Rows.Count, 1).End(3).Row
   
6.     [f:j].UnMerge
   
7.     [h2:j10000] = ""
   
8.     arr = Range("a2:c" & r)
   
9.     ReDim brr(1 To UBound(arr) * 4, 1 To 5)
   
10.     For i = 1 To UBound(arr)
    
11.         m = m + 2
    
12.         brr(m - 1, 1) = arr(i, 1)
    
13.         brr(m, 1) = arr(i, 1)
    
14.         brr(m - 1, 5) = arr(i, 2)
    
15.         brr(m, 5) = arr(i, 2)
    
16.         m = m + 2
    
17.         brr(m - 1, 1) = arr(i, 1)
    
18.         brr(m, 1) = arr(i, 1)
    
19.         brr(m - 1, 5) = arr(i, 3)
    
20.         brr(m, 5) = arr(i, 3)
    
21.     Next
    
22.     [f2].Resize(m, 5) = brr
    
23.     r = Cells(Rows.Count, "f").End(3).Row
    
24.     For i = r To 2 Step -1
    
25.         Set Rng = Cells(i, "f")
    
26.         Set Rng1 = Rng.Offset(-1)
    
27.         If Rng = Rng1 Then
    
28.             Rng1.Resize(2).Merge
    
29.         End If
    
30.         Set Rng = Cells(i, "j")
    
31.         Set Rng1 = Rng.Offset(-1)
    
32.         If Rng = Rng1 Then
    
33.             Rng1.Resize(2).Merge
    
34.         End If
    
35.     Next
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "OK！"
    
38. End Sub
    
39. 
    

复制代码

ykcbf1100

自动合并单元格，附件供参考。。。

飞天篮球猪

FYI...
移动数据（有合并单元格）.xlsm.zip (18.68 KB, 下载次数: 6)

2023-12-24 18:59 上传

点击文件名下载附件

左广恒

gwjkkkkk 发表于 2023-12-24 16:25
请参考附件。。。

你的是正解，对，谢谢你！后面2位的不太好使用，但依然谢谢！

taller

左广恒

gwjkkkkk 发表于 2023-12-24 16:25
请参考附件。。。

正解，谢谢你的帮助！