合并同类项

liaolulu333 · 发表于 2023-4-24 01:01

本帖最后由 liaolulu333 于 2023-4-24 01:11 编辑

弄了几个循环，脑壳都整疼了还是没理清。希望能够得到大佬的帮助。

需求：
A列相同并且B列也相同的，那么C列将其累加。并且只保留一行A列和B列相同的行。
比如：
A5和A8相同，B5和B8也相同。那么C5＝800＋100＝900，将A8:C8整行删除。

原表有几千行的，附件只复制了其中几十行。

liulang0808 · 发表于 2023-4-24 07:17

Sub 按钮1_Click()
Set d = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion
r = 1
For j = 2 To UBound(arr)
      If d.exists(arr(j, 1) & arr(j, 2)) Then
         arr(d(arr(j, 1) & arr(j, 2)), 3) = arr(d(arr(j, 1) & arr(j, 2)), 3) + arr(j, 3)
      Else
         r = r + 1
         For i = 1 To 3
            arr(r, i) = arr(j, i)
         Next i
         d(arr(j, 1) & arr(j, 2)) = r
      End If
Next j
[o1].Resize(r, 3) = arr
End Sub

杨建营 · 发表于 2023-4-24 07:17

用字典和数组很快的

liulang0808 · 发表于 2023-4-24 07:18

https://club.excelhome.net/threa ... tml?_dsign=b73ad3d6

zpy2 · 发表于 2023-4-24 07:51

https://club.excelhome.net/forum.php?mod=viewthread&tid=1655050&fromguid=hot&extra=&mobile&_dsign=dd7289a8

盼盼198310 · 发表于 2023-4-24 07:58

.................

ykcbf1100 · 发表于 2023-4-24 08:42

参与一下，字典排重汇总。

chxw68 · 发表于 2023-4-24 08:54

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:c" & r)
End With
For i = 1 To UBound(arr)
xm = arr(i, 1) & "+" & arr(i, 2)
If Not d.exists(xm) Then
ReDim brr(1 To 3)
brr(1) = arr(i, 1)
brr(2) = arr(i, 2)
Else
brr = d(xm)
End If
brr(3) = brr(3) + arr(i, 3)
d(xm) = brr
Next
With Worksheets("sheet2")
.UsedRange.Offset(1, 0).Clear
.Range("a2").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2023-4-24 08:55

参与一下。

chxw68 · 发表于 2023-4-24 09:01

Sub test2()
' Dim cnn As New ADODB.Connection
' Dim rs As New ADODB.Recordset
Dim sql As String
Dim mybook As String
Dim cnn As Object
Dim rs As Object
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
mybook = ThisWorkbook.FullName
With cnn
If Application.Version = "11.0" Then
.Provider = "microsoft.jet.oledb.4.0"
.ConnectionString = "extended properties=""excel 8.0;HDR=YES;IMEX=1"";data source=" & mybook
Else
.Provider = "microsoft.ACE.oledb.12.0"
.ConnectionString = "extended properties=""excel 12.0;HDR=YES;IMEX=1"";data source=" & mybook
End If
.Open
End With
sql = "select 料号,储位,sum(库存) from [sheet1$a1:c] group by 料号,储位"
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
With Worksheets("sheet2")
.UsedRange.Offset(1, 0).Clear
.Range("a2").CopyFromRecordset rs
End With
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 合并同类项

评分

评分

评分

评分