[已解决]横向合并同类项

张雄友

横向合并同类项。

最佳答案

月排行榜 / 总排行榜

zjdh

2014-6-15 21:03

Sub TEST3()
    Application.DisplayAlerts = False
    ARR = Selection
    Set D = CreateObject("scripting.dictionary")
    For I = 1 To UBound(ARR, 2)
        If ARR(1, I) = "" Then Exit Sub
        If Not D.exists(ARR(1, I)) Then
            D.Add ARR(1, I), 1
        Else
            D(ARR(1, I)) = D(ARR(1, I)) + 1
        End If
    Next
    S = D.ITEMS
    L = Selection.Column - 1
    R = Selection.Row
    For I = 0 To UBound(S)
        If S(I) > 1 Then
            With Range(Cells(R, L + 1), Cells(R, L + S(I)))
                .Merge
                .HorizontalAlignment = xlCenter
                .Borders.LineStyle = xlContinuous
            End With
        Else
            With Cells(R, L + 1)
                .HorizontalAlignment = xlCenter
                .Borders.LineStyle = xlContinuous
            End With
        End If
        L = L + S(I)
    Next
    Application.DisplayAlerts = True
End Sub

跳转到最佳答案楼层

zjdh

横向合并同类项.rar (8.7 KB, 下载次数: 14)

2014-6-15 18:38 上传

点击文件名下载附件

张雄友

zjdh 发表于 2014-6-15 18:38

直接指定区域太死板，用selection 属性你看看对不对？？

1. Sub TEST2()
   
2.     Application.DisplayAlerts = False
   
3.     arr = Selection
   
4.     Set D = CreateObject("scripting.dictionary")
   
5.     For I = 1 To UBound(arr, 2)
   
6.         If Not D.exists(arr(1, I)) Then
   
7.             D.Add arr(1, I), 1
   
8.         Else
   
9.             D(arr(1, I)) = D(arr(1, I)) + 1
   
10.         End If
    
11.     Next
    
12.     S = D.ITEMS
    
13.     L = Selection.Column - 1
    
14.     For I = 0 To UBound(S)
    
15.         If S(I) > 1 Then
    
16.             With Range(Cells(Selection.Row, L + 1), Cells(Selection.Row, L + S(I)))
    
17.                 .Merge
    
18.                 .HorizontalAlignment = xlCenter
    
19.                 .Borders.LineStyle = xlContinuous
    
20.             End With
    
21.         Else
    
22.             With Cells(Selection.Row, L + 1)
    
23.                 .HorizontalAlignment = xlCenter
    
24.                 .Borders.LineStyle = xlContinuous
    
25.             End With
    
26. 
    
27.         End If
    
28.         L = L + S(I)
    
29.     Next
    
30.     Application.DisplayAlerts = True
    
31. End Sub
    

复制代码

张雄友

zjdh 发表于 2014-6-15 18:38

不对的，因为只能执行一次，点多几下就出错了。

rinyxa

简单一点的，呵呵

zjdh

Sub TEST3()
    Application.DisplayAlerts = False
    ARR = Selection
    Set D = CreateObject("scripting.dictionary")
    For I = 1 To UBound(ARR, 2)
        If ARR(1, I) = "" Then Exit Sub
        If Not D.exists(ARR(1, I)) Then
            D.Add ARR(1, I), 1
        Else
            D(ARR(1, I)) = D(ARR(1, I)) + 1
        End If
    Next
    S = D.ITEMS
    L = Selection.Column - 1
    R = Selection.Row
    For I = 0 To UBound(S)
        If S(I) > 1 Then
            With Range(Cells(R, L + 1), Cells(R, L + S(I)))
                .Merge
                .HorizontalAlignment = xlCenter
                .Borders.LineStyle = xlContinuous
            End With
        Else
            With Cells(R, L + 1)
                .HorizontalAlignment = xlCenter
                .Borders.LineStyle = xlContinuous
            End With
        End If
        L = L + S(I)
    Next
    Application.DisplayAlerts = True
End Sub

张雄友

zjdh 发表于 2014-6-15 21:03
Sub TEST3()
    Application.DisplayAlerts = False
    ARR = Selection

如果是相反呢？就是反过来，怎么复原？？

zjdh

还有问题吗？

zjdh

Sub TEST4()
    Application.DisplayAlerts = False
    Selection.UnMerge
    ARR = Selection
    R = Selection.Row
    S = 0
    For I = UBound(ARR, 2) To 1 Step -1
        T = I + Selection.Column - 1
        If ARR(1, I) = "" Then
            S = S + 1
        Else
            Range(Cells(R, T), Cells(R, T + S)) = ARR(1, I)
            S = 0
        End If
    Next
End Sub

coverme

做得越多越好啊