怎样实现累加复制，谢谢老师！

ztd123

累加复制1.zip (19.29 KB, 下载次数: 18)

2019-10-22 16:23 上传

点击文件名下载附件

求助累加复制不删除之前数据，谢谢！

cnmlgb9998

表达要清晰，你说的话，就象是外语一样，没有一点逻辑。把你的意思 ，表达清楚，怎么连个小学生都不如？

ztd123

cnmlgb9998 发表于 2019-10-22 14:38
表达要清晰，你说的话，就象是外语一样，没有一点逻辑。把你的意思 ，表达清楚，怎么连个小学生都不如？

虚心接受老师的教导！

xiangbaoan

Option Explicit
Sub test()
Dim d As Object, ar, br, i&, s$, y&
Set d = CreateObject("Scripting.Dictionary")
ar = Sheets("Sheet3").Range("d5:f" & Sheets("Sheet3").[d65536].End(xlUp).Row)
For i = 1 To UBound(ar)
    s = ar(i, 1) & ar(i, 3)
    If Len(s) Then d(s) = i
Next
br = Sheets("Sheet2").Range("d5:f" & Sheets("Sheet2").[d65536].End(xlUp).Row)
For i = 1 To UBound(br)
    s = br(i, 1) & br(i, 3)
    If d.Exists(s) Then
        y = d(s)
        ar(y, 2) = ar(y, 2) + br(i, 2)
    End If
Next
Sheets("Sheet3").Range("d5:f" & Sheets("Sheet3").[d65536].End(xlUp).Row) = ar
Set d = Nothing
End Sub

ztd123

累加复制1.zip (19.29 KB, 下载次数: 6)

2019-10-22 16:20 上传

点击文件名下载附件

xiangbaoan 发表于 2019-10-22 15:32
Option Explicit
Sub test()
Dim d As Object, ar, br, i&, s$, y&

感谢您，不能过去，麻烦您再给看看，感谢中！

xiangbaoan

ztd123 发表于 2019-10-22 15:50
感谢您，不能过去，麻烦您再给看看，感谢中！

我都是猜的，你不具体说一下，我可真猜不了啦。

YZC51

ztd123 发表于 2019-10-22 15:50
感谢您，不能过去，麻烦您再给看看，感谢中！

请参考
Private Sub CommandButton15_Click()
    ar = Sheet2.[a4].Resize(Sheet2.[a65536].End(3).Row - 3, 42)
    br = ar
   ' m = 1
    For i = 2 To UBound(ar)
        If ar(i, 6) = CDate(ComboBox2.Value) Then
            m = m + 1
            For j = 1 To UBound(ar, 2)
                br(m, j) = ar(i, j)
            Next
        ar(i, 6) = ar(i, 6) + 1
        End If
    Next
    Sheet2.[a4].Resize(UBound(ar), 42) = ar '建行
    Sheet3.UsedRange.Offset(5, 0).ClearContents
    Sheet3.[a5].Resize(m, 42) = br '建行
End Sub

YZC51

代码审核中

xiangbaoan

ztd123 发表于 2019-10-22 15:50
感谢您，不能过去，麻烦您再给看看，感谢中！

………………

lsc900707

cnmlgb9998 发表于 2019-10-22 14:38
表达要清晰，你说的话，就象是外语一样，没有一点逻辑。把你的意思 ，表达清楚，怎么连个小学生都不如？

就是之前复制过去的内容不清除。