VBA代码完善

一休和尚

taller 发表于 2025-4-13 00:54

老师：
如果增加J列和K列合并；N列保存合并后的最后一行的数据；
如何编制；
感谢老师；

taller

1.     ' 没有示例文件，代码未经测试
   
2. 
   
3.     ' 获取最后一行
   
4.     lastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
   
5.    
   
6.     ' ** 反向循环记录最后一行
   
7.     For i = lastRow To 2 Step -1
   
8.         key = ws.Cells(i, "J").Value & "|" & ws.Cells(i, "K").Value
   
9.         
   
10.         If dict.exists(key) Then
    
11.             ' 合并Q列内容
    
12.             If ws.Cells(i, "N").Value <> "" Then
    
13.                 arr = dict(key)
    
14.                 arr(1) = arr(1) & "+" & ws.Cells(i, "N").Value
    
15.                 dict(key) = arr
    
16.             End If
    
17.             If delRows Is Nothing Then
    
18.                 Set delRows = ws.Cells(i, 1)
    
19.             Else
    
20.                 Set delRows = Application.Union(delRows, ws.Cells(i, 1))
    
21.             End If
    
22.         Else
    
23.             ' 记录首行信息 [行号, Q列内容]
    
24.             dict.Add key, Array(i, ws.Cells(i, "N").Value)
    
25.         End If
    
26.     Next i
    
27.    
    
28.     ' 更新首行的n列合并内容
    
29.     For Each key In dict
    
30.         ws.Cells(dict(key)(0), "N").Value = dict(key)(1)
    
31.     Next

复制代码

一休和尚

12楼老师好：
这个代码测试后不行；我上传了附件，里面说明了要求；
第一个表格原始状态；第二个表格是整合后的状态；
请老师帮忙看看如何整改达到要求；
感谢

taller

一休和尚 发表于 2025-4-15 18:31
12楼老师好：
这个代码测试后不行；我上传了附件，里面说明了要求；
第一个表格原始状态；第二个表格是整 ...

没有原始数据表格，没有代码，没有具体需求

一休和尚

taller 发表于 2025-4-16 00:25
没有原始数据表格，没有代码，没有具体需求

老师：

昨天原始数据表格错误了；
这个表格要求和整合前后的都在里面；
帮忙看下；
感谢!

taller

1. Option Explicit
   
2. ' 代码逻辑完全相同，如果合并其他列，请自行调整添加
   
3. Sub 删除IL重复项合并Q()
   
4.     Dim dict As Object
   
5.     Dim lastRow As Long, i As Long
   
6.     Dim key As Variant
   
7.     ' ** 使用Range对象记录需要删除的行，可以一次性删除多行，效率更高
   
8.     Dim delRows As Range
   
9.     Dim ws As Worksheet
   
10.     Dim t As Double, arr
    
11.    
    
12.     Set ws = ActiveSheet
    
13.     Set dict = CreateObject("Scripting.Dictionary")
    
14.     t = Timer
    
15.     Application.ScreenUpdating = False
    
16.     Application.Calculation = xlCalculationManual
    
17.    
    
18.     ' 获取最后一行
    
19.     lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
    
20.    
    
21.     ' ** 正向循环才能记录首行
    
22. 
    
23.     For i = 2 To lastRow
    
24.         key = ws.Cells(i, "I").Value & "|" & ws.Cells(i, "L").Value
    
25.         
    
26.         If dict.exists(key) Then
    
27.             arr = dict(key)
    
28.             ' 按照不同逻辑合并
    
29.             arr(1) = arr(1) & "+" & ws.Cells(i, "J").Value
    
30.             arr(2) = arr(2) & "+" & ws.Cells(i, "K").Value
    
31.             arr(3) = arr(3) & "+" & ws.Cells(i, "L").Value
    
32.             arr(4) = ws.Cells(i, "N").Value
    
33.             dict(key) = arr
    
34.             If delRows Is Nothing Then
    
35.                 Set delRows = ws.Cells(i, 1)
    
36.             Else
    
37.                 Set delRows = Application.Union(delRows, ws.Cells(i, 1))
    
38.             End If
    
39.         Else
    
40.             ' 记录首行信息 [行号, 合并列内容]
    
41.             dict.Add key, Array(i, ws.Cells(i, "J").Value, _
    
42.                 ws.Cells(i, "K").Value, ws.Cells(i, "L").Value, _
    
43.                 ws.Cells(i, "N").Value)
    
44.         End If
    
45.     Next i
    
46.    
    
47.     ' 更新首行的Q列合并内容
    
48.     For Each key In dict
    
49.         i = dict(key)(0)
    
50.         ws.Cells(i, "J").Value = dict(key)(1)
    
51.         ws.Cells(i, "K").Value = dict(key)(2)
    
52.         ws.Cells(i, "L").Value = dict(key)(3)
    
53.         ws.Cells(i, "N").Value = dict(key)(4)
    
54.     Next
    
55. 
    
56.     i = delRows.Cells.Count
    
57.     ' ** 一次性删除合并行
    
58.     delRows.EntireRow.Delete
    
59.    
    
60.     MsgBox "处理完成！" & vbCrLf & _
    
61.            "合并行数：" & i & vbCrLf & _
    
62.            "耗时：" & Format(Timer - t, "0.00") & "秒", _
    
63.            vbInformation
    
64. 
    
65. Cleanup:
    
66.     Application.ScreenUpdating = True
    
67.     Application.Calculation = xlCalculationAutomatic
    
68.     Set dict = Nothing
    
69.     Set delRows = Nothing
    
70. End Sub
    
71. 
    
72. 
    
73. 
    

复制代码