按优先顺序合并单元格

ydwszuibd

求解：如图及附件按优先顺序合并单元格，VBA实现

山菊花

供参考。

ydwszuibd

山菊花 发表于 2023-3-16 17:22
供参考。

niubility

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     vs = Array("皮肤调理剂", "保湿剂", "抗氧化剂", "增溶剂", "溶剂")
   
9.     For j = 0 To UBound(vs)
   
10.         d(vs(j)) = j
    
11.     Next
    
12.     With Worksheets(1)
    
13.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
14.         arr = .Range("a1:c" & r)
    
15.         For i = 4 To UBound(arr)
    
16.             If .Cells(i, 1).MergeArea.Cells(1, 1).Address = .Cells(i, 1).Address Then
    
17.                 hs = .Cells(i, 1).MergeArea.Rows.Count
    
18.                 If hs > 1 Then
    
19.                     n = 10
    
20.                     For j = 1 To hs
    
21.                         If d.exists(arr(i + j - 1, 3)) Then
    
22.                             If n > d(arr(i + j - 1, 3)) Then
    
23.                                 n = d(arr(i + j - 1, 3))
    
24.                             End If
    
25.                         End If
    
26.                     Next
    
27.                     .Cells(i, 3).Resize(hs, 1).Merge
    
28.                     .Cells(i, 3) = vs(n)
    
29.                 End If
    
30.             End If
    
31.         Next
    
32.     End With
    
33. End Sub
    

复制代码

chxw68

详见附件。