如何用VBA实现同列下相同名称值合并，且对应列的值求和汇总

鹦鹉好烦猫

lsdongjh 发表于 2017-12-20 15:47
会用、善用用新的EXCLE

你好 这些功能区的按键是哪个版本？怎么我的2016版都没有？

jjmysjg

留下记号，谢谢

chenchen1985

原工作薄的sheet1，sheet2，sheet3 表中都带有“马名”列。下面代码的功能是根据sheet1 的“马名” 生成不同的工作簿， 但是新的工作簿们中没有sheet2，sheet3的内容。
大神们！能否帮忙完善代码？在保持现有功能的情况下，让每个工作簿里也带上sheet2，sheet3 表 ，每个表都显示对应“马名”的内容？

Option Explicit
Sub test()
Dim p$, d As Object, ar, rng As Range, r&, i%, nm$, s$
Application.ScreenUpdating = False
p = ThisWorkbook.Path & "\拆分"
If Dir(p, vbDirectory) = "" Then MkDir p
p = p & "\"
Set d = CreateObject("scripting.dictionary")
'On Error Resume Next
With Sheet1
    .UsedRange.Offset(1).UnMerge
    Set rng = .[a1].Resize(1, 20)
    ar = .Range("a1:a" & .[g65536].End(xlUp).Row)
    For r = 2 To UBound(ar)
        s = Replace(Trim(ar(r, 1)), " ", "")
        If Len(s) Then
            If Not d.exists(s) Then
                Set d(s) = .Cells(r, 1).Resize(1, 20)
            Else
                Set d(s) = Union(d(s), .Cells(r, 1).Resize(1, 20))
            End If
        End If
    Next
End With
Application.DisplayAlerts = False
For i = 0 To d.Count - 1
    nm = d.keys()(i)
    With Workbooks.Add
        With .Sheets(1)
            .Name = nm
            rng.Copy .[a1]
            d.items()(i).Copy .[a2]
            .[a:t].EntireColumn.AutoFit
        End With
        .SaveAs p & nm & ".xlsx", xlOpenXMLWorkbook
        .Close
    End With
Next
Set rng = Nothing
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = False
MsgBox "OK!"
End Sub

chenchen1985

chenchen1985 发表于 2019-10-11 07:20
原工作薄的sheet1，sheet2，sheet3 表中都带有“马名”列。下面代码的功能是根据sheet1 的“马名” 生成不 ...

好的，谢谢！

chenchen1985

这个可行，谢谢！

tbwx

chxw68 发表于 2017-12-20 14:30

项目名称中第一个为啥统计不出来？

紫寒100

学习来了。