对含有合并单元格所在行的原料组分之间进行降序排列

山海风云轩

求助大佬：工作中，有时候配方表中的某原料属于复配原料，里面的各个组分不一定降序排列，

想用VBA代码对其进行降序，详情请见附件
初始图：

效果图：

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.30
   
2.     r = Cells(Rows.Count, 2).End(3).Row
   
3.     For i = 4 To r
   
4.         Set Rng = Cells(i, 4)
   
5.         If Rng.MergeCells = True Then
   
6.             m = Rng.MergeArea.Count
   
7.             Set rng1 = Cells(i, 5).Resize(m)
   
8.             rng1.Sort Cells(i, 5), 2
   
9.             Set rng2 = Cells(i, 6).Resize(m)
   
10.             rng2.Sort Cells(i, 6), 2
    
11.         End If
    
12.         i = i + m - 1
    
13.     Next
    
14. End Sub
    

复制代码

山海风云轩

ykcbf1100 发表于 2024-3-30 16:52
参与一下。。。

感谢大佬的关注，可以再帮忙看看吗？
刚才测试了一下，第5列和第6列是降序了
前面，我没表述清楚，
需求是：对应的整行进行降序，不是只对第5列和第6列降序
比如附录中，第6号原料，水对应的含量百分比是25.92%，聚二甲基硅氧烷的含量百分比是64.0764%，
那么需要将聚二甲基硅氧烷整行排在水的上面

ykcbf1100

山海风云轩 发表于 2024-3-30 19:21
感谢大佬的关注，可以再帮忙看看吗？
刚才测试了一下，第5列和第6列是降序了
前面，我没表述清楚 ...

你搞那么多合并单元格，如果整行排序的话，全部要把数据填充回去才能排序的，排序后还得继续合并回去。
算了，你自己整整吧。

yjh_27

ykcbf1100 发表于 2024-3-31 12:32
你搞那么多合并单元格，如果整行排序的话，全部要把数据填充回去才能排序的，排序后还得继续合并回去。
...

参见附件。

ykcbf1100

yjh_27 发表于 2024-3-31 19:09
参见附件。

你是好人。

ykcbf1100

山海风云轩 发表于 2024-3-30 19:21
感谢大佬的关注，可以再帮忙看看吗？
刚才测试了一下，第5列和第6列是降序了
前面，我没表述清楚 ...

好吧，现在我有闲，虽然麻烦一点，我还是帮你完成了吧。

记得送我2朵小花哦。

ykcbf1100

代码如下，里面有自定义函数

1. Sub ykcbf()  '//2024.3.31
   
2.     On Error Resume Next
   
3.     With Sheets("洗发乳")
   
4.         r = .Cells(Rows.Count, 3).End(3).Row
   
5.         zr = Array(1, 4)
   
6.         Call nhb(3, 4, zr)
   
7.         Set rng = .[a3].Resize(r - 2, 6)
   
8.         With rng
   
9.             .Parent.Sort.SortFields.Clear
   
10.             .Sort Key1:=.Item(1), Order1:=1, Key2:=.Item(5), Order2:=2, Header:=2
    
11.         End With
    
12.         For i = r To 3 Step -1
    
13.             Set rng = .Cells(i, 1)
    
14.             Set Rng1 = rng.Offset(-1)
    
15.             If rng = Rng1 Then
    
16.                 For x = 0 To UBound(zr)
    
17.                     .Cells(i, zr(x)).Offset(-1).Resize(2).Merge
    
18.                 Next
    
19.             End If
    
20.         Next
    
21.     End With
    
22. End Sub

复制代码

山海风云轩

yjh_27 发表于 2024-3-31 19:09
参见附件。

感谢大佬