VBA智能化汇总类型，难度比较高，鲜花奉上！

humanmagic

1. Sub Demo()
   
2. 
   
3.     Dim findArr(), arr(), sht1 As Worksheet, sht2 As Worksheet
   
4.     Set sht1 = Sheets("成品入库登记表")
   
5.     Set sht2 = Sheets("成品库存统计表")
   
6.     arr = sht1.Range("I4:I" & sht1.Range("I4").End(xlDown).Row)
   
7.     Dim i As Long, j As Long, maxDate
   
8.     maxDate = arr(1, 1)
   
9.     For i = LBound(arr) + 1 To UBound(arr)
   
10.         If maxDate < arr(i, 1) Then
    
11.             maxDate = arr(i, 1)
    
12.         End If
    
13.     Next i
    
14.     j = 1
    
15.     For i = LBound(arr) + 1 To UBound(arr)
    
16.         If maxDate = arr(i, 1) Then
    
17.             ReDim Preserve findArr(1 To j)
    
18.             findArr(j) = i + 3
    
19.             j = j + 1
    
20.         End If
    
21.     Next i
    
22.     Dim rng As Range, bl As Boolean, firstAddress As String
    
23.     For i = LBound(findArr) To UBound(findArr)
    
24.         Set rng = sht2.Range("B3:B" & sht2.Cells(Rows().Count, 2).End(xlUp).Row).Find(sht1.Cells(findArr(i), 2).Value, , , xlWhole)
    
25.         If rng Is Nothing Then
    
26.             With sht2.Cells(sht2.Rows().Count, 2).End(xlUp)
    
27.                 If IsNumeric(.Offset(0, -1).Value) Then
    
28.                     .Offset(1, -1).Value = .Offset(0, -1).Value + 1
    
29.                 Else
    
30.                     .Offset(1, -1).Value = 1
    
31.                 End If
    
32.                 .Offset(1, 0).Value = sht1.Cells(findArr(i), 2).Value
    
33.                 .Offset(1, 1).Value = sht1.Cells(findArr(i), 3).Value
    
34.                 .Offset(1, 2).Value = sht1.Cells(findArr(i), 4).Value
    
35.                 .Offset(1, 3).Value = sht1.Cells(findArr(i), 5).Value
    
36.                 .Offset(1, 4).Value = sht1.Cells(findArr(i), 6).Value
    
37.             End With
    
38.         Else
    
39.             firstAddress = rng.Address
    
40.             Do
    
41.                 If rng.Offset(0, 3).Value = sht1.Cells(findArr(i), 5).Value Then
    
42.                     rng.Offset(0, 4).Value = rng.Offset(0, 4).Value + sht1.Cells(findArr(i), 6).Value
    
43.                     bl = True
    
44.                     Exit Do
    
45.                 End If
    
46.                 Set rng = sht2.Range("B3:B" & sht2.Cells(Rows().Count, 2).End(xlUp).Row).FindNext(rng)
    
47.             Loop While Not rng Is Nothing And rng.Address <> firstAddress
    
48.             If Not bl Then
    
49.                 With sht2.Cells(sht2.Rows().Count, 2).End(xlUp)
    
50.                     If IsNumeric(.Offset(0, -1).Value) Then
    
51.                         .Offset(1, -1).Value = .Offset(0, -1).Value + 1
    
52.                     Else
    
53.                         .Offset(1, -1).Value = 1
    
54.                     End If
    
55.                     .Offset(1, 0).Value = sht1.Cells(findArr(i), 2).Value
    
56.                     .Offset(1, 1).Value = sht1.Cells(findArr(i), 3).Value
    
57.                     .Offset(1, 2).Value = sht1.Cells(findArr(i), 4).Value
    
58.                     .Offset(1, 3).Value = sht1.Cells(findArr(i), 5).Value
    
59.                     .Offset(1, 4).Value = sht1.Cells(findArr(i), 6).Value
    
60.                 End With
    
61.             End If
    
62.             bl = False
    
63.         End If
    
64.     Next i
    
65. 
    
66. End Sub

复制代码

约定的童话

humanmagic 发表于 2018-8-21 20:58
这是因为你清空了之后，B4.End(XlDown)直接到了工作表最下面一行，后面的代码添加新行肯定报错。

明白了，我想一下有没有好办法解决这个问题

约定的童话

ivccav 发表于 2018-8-21 16:37
请查收附件：

大神，是汇总求和到第二个表里面，参考1楼的思路

microyip

1. Sub 查找()
   
2.     Dim oConn As Object, sSelect As String
   
3.     Dim nRow As Double
   
4.    
   
5.     nRow = Sheets("成品入库登记表").Cells(Rows.Count, 9).End(xlUp).Row
   
6.     Set oConn = CreateObject("Adodb.Connection")
   
7.     If Val(Application.Version) < 12 Then
   
8.         oConn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName '建立数据库连接
   
9.     Else
   
10.         oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName '建立数据库连接
    
11.     End If
    
12.    
    
13.     sSelect = "Select [产品编号],[产品名称],[规格],[品牌],[数量] From [成品入库登记表$A3:I" & nRow & "] " & _
    
14.         "Where [入库时间] in (" & _
    
15.             "Select A.[入库时间] From (Select [入库时间],abs([入库时间]-#" & Date & "#) as 日期差 From [成品入库登记表$A3:I" & nRow & "] group by [入库时间]) As A " & _
    
16.                 "Where A.[日期差] in (Select min([日期差]) From (Select [入库时间],abs([入库时间]-#" & Date & "#) as 日期差 From [成品入库登记表$A3:I" & nRow & "] group by [入库时间])))"
    
17.     Sheets("成品库存统计表").Cells(Rows.Count, 2).End(xlUp).Offset(1).CopyFromRecordset oConn.Execute(sSelect)
    
18.     oConn.Close
    
19.     Set oConn = Nothing
    
20. End Sub

复制代码

microyip

附上附件以供参考

ivccav

约定的童话 发表于 2018-8-22 08:14
大神，是汇总求和到第二个表里面，参考1楼的思路

我的程序就是把第一个表汇总到第二个表里面，跟你1楼的思路完全一致。

我为了避免频繁操作Range对象和Find方法而造成运行效率低下，才改为数组+字典。

Find方法适合只找1次的情况，如果循环多次，效率非常低，应该用字典。用数组循环也比Range循环快很多倍。因为数组的数据是存放在内存中的。使用字典则不需要循环，一次到位，查找数据非常快。

你试试就知道是否正确了。2楼的代码是有问题的，xlDow是向下找，所以你清空表二数据就报错了，且使用range对象和find方法来操作数据，在数据多的情况下，速度可能会慢几百倍以上。
2楼应该是初学者，写的代码还是比较原始的，跟我开始写代码的时候一样，程序效率很低。我开始写的代码经常运行几分钟，后来用数组和字典，基本都是1秒以内了。

约定的童话

ivccav 发表于 2018-8-22 10:29
我的程序就是把第一个表汇总到第二个表里面，跟你1楼的思路完全一致。

我为了避免频繁操作Range对象和 ...

可是我运行结果都是在第一个表累积的？难道我下错文件了？

约定的童话

microyip 发表于 2018-8-22 09:43
附上附件以供参考

数据库都出来了啊，超神级的代码啊，跪拜！！！

ivccav

约定的童话 发表于 2018-8-22 14:41
可是我运行结果都是在第一个表累积的？难道我下错文件了？

不是文件下错了，而是你在第一个表内运行代码，第一个表成了活动工作表。你在表二建个按钮就行了。

为了不捆绑固定的工作表，我特意没有指定输出数据的表名，而让数据输出到任意活动工作表内。

VBA中操作对象是非常慢的，如2楼的代码。ADO（操作数据库的对象）操作EXCEL能减少代码，但是因为EXCEL不是数据库，效率也不会高。你复制几千上万的数据试试就知道运行效率了。

算了，为了这个简单的问题，浪费这么多笔墨。你什么自己爱用什么方式就什么方式吧。我只提供速度快，容易懂的代码。我写的代码都是验证过才发出来的，并不是你说的那种结果。

约定的童话

ivccav 发表于 2018-8-22 14:58
不是文件下错了，而是你在第一个表内运行代码，第一个表成了活动工作表。你在表二建个按钮就行了。

为 ...

收到，大神，我说呢，原来我在第一个表运行了.....