求批量合并及取消合并代码

360527010

请教各位大侠如何实现如下要求：相同年份及月份的单元格自动合并，取消合并之后能恢复原样,具体详见附件。感谢各位大佬!

taller

1. 
   
2. Sub MergeDemo()
   
3.     Dim dicMth As Object, dicYr As Object, rngData As Range
   
4.     Dim i As Long, iYr, iMth, vKey, aTmp(1), aTmp2
   
5.     Dim arrData
   
6.     Const START_COL = 3
   
7.     Sheet2.Copy , Sheets(Sheets.Count)
   
8.     Set dicMth = CreateObject("scripting.dictionary")
   
9.     Set dicYr = CreateObject("scripting.dictionary")
   
10.     Set rngData = Range("A3").CurrentRegion
    
11.     arrData = rngData.Value
    
12.     For i = START_COL To UBound(arrData, 2)
    
13.         iYr = CStr(arrData(1, i))
    
14.         iMth = arrData(1, i) & "|" & arrData(2, i)
    
15.         UpdateDic dicYr, iYr, 3, i
    
16.         UpdateDic dicMth, iMth, 4, i
    
17.     Next i
    
18.     Application.DisplayAlerts = False
    
19.     If dicYr.Count > 0 Then
    
20.         For Each vKey In dicYr.Keys
    
21.             dicYr(vKey)(0).Resize(1, dicYr(vKey)(1)).Merge
    
22.         Next
    
23.     End If
    
24.     If dicMth.Count > 0 Then
    
25.         For Each vKey In dicMth.Keys
    
26.             dicMth(vKey)(0).Resize(1, dicMth(vKey)(1)).Merge
    
27.         Next
    
28.     End If
    
29.     Application.DisplayAlerts = True
    
30.    
    
31. End Sub
    
32. 
    
33. Sub UpdateDic(ByRef oDic As Object, vKey, iRow, iCol)
    
34.     Dim aTmp(1), aTmp2
    
35.     If oDic.exists(vKey) Then
    
36.         aTmp2 = oDic(vKey)
    
37.         aTmp2(1) = aTmp2(1) + 1
    
38.         oDic(vKey) = aTmp2
    
39.     Else
    
40.         Set aTmp(0) = Cells(iRow, iCol)
    
41.         aTmp(1) = 1
    
42.         oDic(vKey) = aTmp
    
43.     End If
    
44. End Sub
    
45. 
    

复制代码

taller

1. Sub UnMergeDemo()
   
2.     Dim rngData As Range
   
3.     Sheet2.Copy , Sheets(Sheets.Count)
   
4.     Range("A3:B5").Copy Range("A10")
   
5.     With Range("A10").CurrentRegion
   
6.         Set rngData = .Offset(0,1).Resize(,.Columns.Count-1)
   
7.     End With
   
8.     With rngData
   
9.         .UnMerge
   
10.         .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]"
    
11.         .Formula = .Value   
    
12.     End With
    
13. End Sub

复制代码

Qs18

1. Sub qs() '合并单元格
   
2. Application.DisplayAlerts = False
   
3. For c = 1 To 3
   
4.     For i = 119 To 3 Step -1
   
5.         If Sheet2.Cells(c + 18, i - 1) = Sheet2.Cells(c + 18, i) Then
   
6.         Union(Sheet2.Cells(c + 18, i), Sheet2.Cells(c + 18, i - 1)).Merge
   
7.         
   
8.         End If
   
9.     Next
   
10. Next
    
11. Application.DisplayAlerts = True
    
12. End Sub
    
13. Sub qs取消合并()
    
14. Dim s
    
15. With Sheet2
    
16. For c = 1 To 2
    
17. For i = 3 To 119
    
18.     s = .Cells(c + 18, i).Value
    
19.     n = .Cells(c + 18, i).MergeArea.Count
    
20.     .Cells(c + 18, i).UnMerge
    
21.     Range(Cells(c + 18, i), Cells(c + 18, i + n - 1)).Value = s
    
22.     i = i + n - 1
    
23. Next
    
24. Next
    
25. End With
    
26. End Sub
    

复制代码

Qs18

试试...........

Qs18

试试............

360527010

taller 发表于 2024-9-7 22:33

感谢大佬！！

360527010

Qs18 发表于 2024-9-8 07:19
试试............

非常感谢，另外还有个问题，能否在取消合并的时候对应的行输入公式？根据日对应的日期分别提取其年份和月份？