VBA实现B列所有重复的行，对应C列的所有值求和后只保留一行

rkrkrk123

各位大神好！

本人初学者，想学习实现以下效果；请大家指导。
VBA实现B列“编号”如果有重复的值，对应C列的“数量”求和，然后B列进行去重，保留对应C列求和后的那一行；其它列不变


大家可以参考附件，由SHeet1 变成sheet2的效果。

需要
谢谢。

renkangjizhen

用字典法可以实现

A1233515

典型的字典应用

A1233515

附件供参考

xiangbaoan

Sub test()
  Dim Cn As Object, Rs As Object, Sq As String, ar, i As Integer
  Set Cn = CreateObject("ADODB.Connection")
  Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  With Worksheets(1)
    ar = .[a1:e1 & ""]
    Sq = "SELECT FIRST(" & ar(1) & ") AS " & ar(1) & "," & ar(2) & ",SUM(" & ar(3) & ") AS " & ar(3) & ", FIRST(" & ar(4) & ") AS " & ar(4) & ", FIRST(" & ar(5) & ") AS " & ar(5) & _
         " FROM [" & .Name & "$" & .Range("A1").CurrentRegion.Address(0, 0) & "] GROUP BY " & ar(2)
  End With
  Set Rs = Cn.Execute(Sq)
  With Worksheets(2).Range("A1")
    .CurrentRegion.ClearContents
    For i = 0 To Rs.Fields.Count - 1
      .Offset(0, i) = Rs.Fields(i).Name
    Next
    .Offset(1).CopyFromRecordset Rs
  End With
  Set Rs = Nothing: Cn.Close: Set Cn = Nothing: Beep
End Sub

xiangbaoan

一把小刀闯天下

'如果编号有序这样也可以，，，

Option Explicit

Sub test()
  Dim arr, i, j, m, p, sum
  arr = Sheets("sheet1").[a1].CurrentRegion.Offset(1).Value
  For i = 1 To UBound(arr, 1) - 1
    sum = sum + arr(i, 3)
    If arr(i, 2) <> arr(i + 1, 2) Then
      m = m + 1
      For j = 1 To UBound(arr, 2)
        arr(m, j) = arr(p + 1, j)
      Next
      p = i: arr(m, 3) = sum: sum = 0
    End If
  Next
  Sheets("sheet2").[a2].Resize(m, UBound(arr, 2)) = arr
End Sub

rkrkrk123

A1233515 发表于 2021-2-25 09:38
典型的字典应用

谢谢你。
但是我想实现在Sheet1（原工作表）中实现，不需要重新再新建sheet2。
该怎么实现呢？

于箱长

rkrkrk123 发表于 2021-3-2 10:30
谢谢你。
但是我想实现在Sheet1（原工作表）中实现，不需要重新再新建sheet2。
该怎么实现呢？

把结果输出到你想要改的位置就行了啊

rkrkrk123

于箱长 发表于 2021-3-2 11:50
把结果输出到你想要改的位置就行了啊

改了，不行啊。
C:\Users\zhaocn\Desktop\44444444.jpg