Sub AwTest()
Dim i&, j%, k%, m%, c%, arr, tempAr, d As Object
Set d = CreateObject("Scripting.Dictionary")
With Sheets("样品类")
tempAr = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(3))
End With
With Sheets("订单明细")
arr = .[a1].CurrentRegion
ReDim brr(1 To 10000, 1 To 4) '已修改
For i = 2 To UBound(arr)
c = 0
For j = 1 To UBound(tempAr)
If InStr(arr(i, 13), tempAr(j, 1)) Then
c = 4: Exit For
Else
c = 3
End If
Next
If c = 3 Then
If Not d.exists(CStr(arr(i, 4))) Then
k = k + 1
d(CStr(arr(i, 4))) = k
brr(k, 1) = arr(i, 4)
brr(k, 2) = 1
brr(k, 3) = Val(arr(i, 17)) '已修改,明细表中的数量列为文本型数字
Else
m = d(CStr(arr(i, 4)))
brr(m, 2) = brr(m, 2) + 1
brr(m, 3) = brr(m, 3) + Val(arr(i, 17)) '已修改,明细表中的数量列为文本型数字
End If
ElseIf c = 4 Then
If Not d.exists(CStr(arr(i, 4))) Then
k = k + 1
d(CStr(arr(i, 4))) = k
brr(k, 1) = arr(i, 4)
brr(k, c) = 1
Else
m = d(CStr(arr(i, 4)))
brr(m, c) = brr(m, c) + 1
End If
End If
Next
End With
With Sheets("计算数据")
.[a1].CurrentRegion.Offset(1).Resize(.[a1].CurrentRegion.Rows.Count, 4) = ""
.[a2].Resize(k, 4) = brr
End With
End Sub |