复制行并修改内容如何让代码运行更快？

ajgdm122

表格里司机这2列，有双人或三人的，需要拆分；


拆分后对应的数据除以2或者3，2人的除2,3人的除3


效果图

问题：里面我写了代码，用可以用，但非常慢，我是先录了一段宏之后修改的，请教各位有无更好的代码可以赐教？因为数据有时很多，我自己写的运行太慢了。

牛牛神哦

文件上传了看看

q490525427

关闭屏幕刷新

ykcbf1100

你这是汇总表一行改多行？

gwjkkkkk

被取数表格有些不规范，取数比较难。。。

ykcbf1100

附件供参考，代码关键地方有标注。

ykcbf1100

参与一下。。。

1. Sub 拆分多勾机手2()  '//2024.4.15
   
2.     With Sheets("汇总表")
   
3.         r = .Range("a1").End(xlDown).Row '取R列
   
4.         arr = .[a1].Resize(r, 24)
   
5.         zrr = .[a1].Resize(r, 24)
   
6.         ReDim brr(1 To 10000, 1 To UBound(arr, 2))
   
7.         On Error Resume Next
   
8.         For i = 2 To 23   'UBound(arr)   '//确认无误后,23改为UBound(arr)即可.
   
9.             If arr(i, 1) <> Empty Then
   
10.                 For j = 17 To 18
    
11.                     If InStr(arr(i, j), "、") Then
    
12.                         m = m + 1
    
13.                         For k = 1 To 16
    
14.                             brr(m, k) = arr(i, k)
    
15.                         Next
    
16.                         c1 = 22
    
17.                         brr(m, 21) = arr(i, 21): brr(m, c1) = arr(i, c1)
    
18.                         p = arr(i, c1)   '//孔深
    
19.                         n = UBound(b) + 1  '//人数
    
20.                         p1 = Round(p / n, 2)  '//孔深拆分
    
21.                         b = Split(arr(i, j), "、")
    
22.                         For x = 0 To UBound(b)
    
23.                             m = m + 1
    
24.                             For k = 1 To 16
    
25.                                 brr(m, k) = arr(i, k)
    
26.                             Next
    
27.                             brr(m, j) = b(x)
    
28.                             brr(m, j + 6) = p1
    
29.                         Next
    
30.                     End If
    
31.                 Next
    
32.             End If
    
33.         Next
    
34.         .[a26].Resize(m, 24) = brr   '//数据暂写在26行开始的地方,确认无误后,.[a26]改为.[a2]即可.
    
35.         .[a1].Select
    
36.     End With
    
37.     MsgBox "拆分勾机手完成！"
    
38. End Sub

复制代码

ajgdm122

ykcbf1100 发表于 2024-4-15 19:32
参与一下。。。

修改了内容后能完美运行了，感谢大哥~~