合并单元格结果不对？

ning84

没有用好Set oRng = Union(oRng, Rng(ii, jj))

1. Sub Macro1()
   
2.    Application.DisplayAlerts = False
   
3.    Dim Sht As Worksheet
   
4.       
   
5.    Dim Rng As Range, oRng As Range
   
6.        Set Rng = Selection
   
7.        Set Sht = Rng.Parent
   
8.    Dim Str As String
   
9.    Dim ii: ii = 1
   
10.        Set Rng = Sht.Cells(20, 1).CurrentRegion
    
11.        Debug.Print Rng.Address
    
12.        For jj = 1 To 3
    
13.            Set oRng = Rng(ii, jj)
    
14.            For ii = 1 To Rng.Rows.Count
    
15.                ''
    
16.                If Rng(ii, jj) = Rng(ii + 1, jj) Then
    
17.                    Set oRng = Union(oRng, Rng(ii, jj))
    
18.                    Debug.Print oRng.Address
    
19.                ElseIf Rng(ii, jj) <> Rng(ii + 1, jj) Then
    
20.                    'Debug.Print oRng(2, 1).Resize(oRng.Rows.Count).Address
    
21.                    'oRng(2, 1).Resize(oRng.Rows.Count).Merge
    
22.                    Debug.Print oRng.Address
    
23.                    oRng.Merge
    
24.                    Set oRng = Rng(ii, jj)
    
25.                End If
    
26.            Next ii
    
27.            ii = 1
    
28.        Next jj
    
29.        Application.DisplayAlerts = True
    
30. End Sub
    

复制代码

边缘码农

没有附件，盲猜一下。
包含日期时间的这一列，按已使用列数进行循环，取出第一行的年、月、日，再依次取出第2-N行的年、月、日，逐个和第一行核对，完全一致的，使用union联合，存在不一致的，已经使用union联合的单元格合并。大约是这样的流程。

wang-way

自己调用一下吧

1. Public Sub MergeSameItem(ByVal RngWithTitle As Range, Optional MergeColumnNo As Long = 1)
   
2.     '''禁止合并单元格过程中出现警告提示
   
3.     Application.DisplayAlerts = False
   
4.     Dim i As Integer
   
5.     Dim RowCount As Long
   
6.     Dim LastRow As Long
   
7.     Dim FirstRow As Long
   
8.     With RngWithTitle
   
9.         '''根据A列序号合并A列
   
10.         RowCount = .Cells.Rows.count
    
11.         LastRow = RowCount
    
12.         For i = RowCount To 2 Step -1
    
13.             If .Cells(i, MergeColumnNo).Value <> .Cells(i - 1, MergeColumnNo).Value Then     '若前后行内容不同
    
14.                 FirstRow = i    '记下合并区域的起始行
    
15.                 .Cells(FirstRow, MergeColumnNo).Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区
    
16.                 LastRow = i - 1    '调整下一个区域的终止行
    
17.             End If
    
18.         Next i
    
19.     End With
    
20.     Application.DisplayAlerts = True    '恢复警告提示
    
21. End Sub
    

复制代码

ww87725244

合并单元格----要倒序

边缘码农

他这个，是根据B列合并A列，应该不用倒序。

ning84

wang-way 发表于 2024-7-8 16:33
自己调用一下吧

谢谢解答。

1. Sub Macro1()
   
2.    Application.DisplayAlerts = False
   
3.    Dim Sht As Worksheet, Sht1 As Worksheet
   
4.        Set Sht = Sheet1
   
5.        Set Sht1 = Sheet6
   
6.    Dim Rng As Range, oRng As Range
   
7.    Dim Str As String
   
8.    Dim ii: ii = 1
   
9.        With Sht1
   
10.            Set Rng = .Cells(10, 1).CurrentRegion
    
11.            'Debug.Print Rng.Address
    
12.        End With
    
13.        ''
    
14.        With Sht
    
15.           .Cells.Clear
    
16.           .Activate
    
17.           Rng.Copy
    
18.           .Cells(5, 1).PasteSpecial xlPasteAll
    
19.          
    
20.           Set Rng = .Cells(20, 1).CurrentRegion
    
21.           Rng.Select
    
22.        End With
    
23. 
    
24.        Rng.Sort key1:=Rng(, 4), Order1:=xlAscending  'xlDescending
    
25.       
    
26.        ''
    
27.        For jj = 1 To 3
    
28.           MergeRng Rng(, jj).Resize(Rng.Rows.Count, 1)
    
29.        Next jj
    
30.        With Rng.Borders
    
31.            .LineStyle = 1
    
32.            .Weight = 3
    
33.        End With
    
34.       
    
35.        Application.DisplayAlerts = True
    
36. End Sub
    
37. 
    
38. Function MergeRng(Rng As Range)
    
39.   Dim LastRow, FirstRow
    
40.   Dim ii, jj
    
41.   Dim Sht As Worksheet
    
42.      Set Sht = Rng.Parent
    
43.      With Rng.Parent
    
44.         LastRow = Rng.Row + Rng.Rows.Count - 1
    
45.         For ii = Rng.Row + Rng.Rows.Count - 1 To 2 Step -1
    
46.             If .Cells(ii, Rng.Column).Value <> .Cells(ii - 1, Rng.Column).Value Then
    
47.                 FirstRow = ii
    
48.                 .Cells(FirstRow, Rng.Column).Resize(LastRow - FirstRow + 1, 1).Merge
    
49.                 LastRow = ii - 1
    
50.             End If
    
51.         Next ii
    
52.      End With
    
53. End Function
    

复制代码

ning84

程序优化
                If FirstRow < Rng.Row Then
                    Exit Function
                End If

1. 
   
2. Function MergeRng(Rng As Range)
   
3.   Dim LastRow, FirstRow
   
4.   Dim ii, jj
   
5.   Dim Sht As Worksheet
   
6.      Set Sht = Rng.Parent
   
7.      With Rng.Parent
   
8.         LastRow = Rng.Row + Rng.Rows.Count - 1
   
9.         For ii = Rng.Row + Rng.Rows.Count - 1 To 2 Step -1
   
10.             Debug.Print .Cells(ii, Rng.Column).Address
    
11.             'Debug.Print Rng.Address
    
12.             
    
13.             
    
14.             If .Cells(ii, Rng.Column).Value <> .Cells(ii - 1, Rng.Column).Value Then
    
15.                 FirstRow = ii
    
16.                 If FirstRow < Rng.Row Then
    
17.                     Exit Function
    
18.                 End If
    
19.                 .Cells(FirstRow, Rng.Column).Resize(LastRow - FirstRow + 1, 1).Merge
    
20.                 LastRow = ii - 1
    
21.             End If
    
22.         Next ii
    
23.      End With
    
24. End Function
    
25. 
    

复制代码

1. <p>
   
2. </p><p>Private Sub deldeldeldeldelde()</p><p>   Application.DisplayAlerts = False</p><p>   Dim Rng As Range, oRng As Range</p><p>       Set Rng = Selection</p><p>   Dim Sht As Worksheet</p><p>       Set Sht = Rng.Parent</p><p>       With Sht</p><p>          Set Rng = .Range(.Cells(4, 1).Formula)</p><p>          Debug.Print Rng.Address</p><p>          Set oRng = Rng(3, 1).Resize(Rng.Rows.Count - 2, Rng.Columns.Count)</p><p>          For jj = 1 To 3</p><p>             'Set oRng = oRng(, 3).Resize(oRng.Rows.Count, 1)</p><p>             MergeRng oRng(, jj).Resize(oRng.Rows.Count, 1)</p><p>          Next jj</p><p>          </p><p>       End With</p><p>       Application.DisplayAlerts = True</p><p>End Sub</p><p></p>

复制代码