作者：绿色风
分类：
时间：2022-08-18
浏览：103
楼主
amulee |
一个合并计算的小改版，目前只有求和功能，效果如下：
简单的复制粘贴就可以进行求和汇总，并根据实际情况合并重复的项目。
有兴趣的朋友可以对代码修改完善。
核心代码很简单，参考如下：- Sub MPaste()
- On Error GoTo ErrHandle
- Dim DaOb As New DataObject
- Dim Rng As Range
- Dim d As Object
- Dim Arr, ArrTemp, ArrYS, Ct As Long
- Dim Txt As String
- DaOb.GetFromClipboard
- Txt = DaOb.GetText
- Arr = Split(Txt, vbCrLf)
- ReDim Preserve Arr(1 To UBound(Arr))
- ReDim ArrTemp(1 To UBound(Arr))
- For i = 1 To UBound(Arr)
- ArrTemp(i) = Split(Arr(i), vbTab)
- Next
- ArrTemp = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ArrTemp))
- ArrYS = Application.Selection
- Set Rng = Application.Selection(1)
- Set d = CreateObject("Scripting.Dictionary")
- Ct = UBound(ArrYS)
- '记录原始数据
- For i = 1 To Ct
- d(ArrYS(i, 1)) = d(ArrYS(i, 1)) + ArrYS(i, 2)
- Next i
- '汇总新数据
- For i = 1 To UBound(ArrTemp)
- d(ArrTemp(i, 1)) = d(ArrTemp(i, 1)) + ArrYS(i, 2)
- Next i
- '重新写入单元格
- '清除原数据
- Application.Selection.ClearContents
- '计算行数
- If Ct < d.Count Then
- Application.Selection.Rows(Application.Selection.Rows.Count).Offset(1, 0).Resize(d.Count - Ct, Application.Selection.Columns.Count).Select
- Application.Selection.Insert shift:=xlShiftDown
- End If
- Rng.Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
- Rng.Offset(0, 1).Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
- End
- ErrHandle:
- Select Case Err.Number
- Case -2147221404
- MsgBox "未复制源数据"
- Case 9
- MsgBox "请确认数据源是否正确"
- End Select
- End Sub
附件下载：
 粘贴汇总.zip
 该帖已经同步到 |
2楼
angel928 |
VB代码好长啊，学习中 |
3楼
JOYARK1958 |
謝謝提供學習下載中 |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一