新人求助，代码执行时出现死机，为什么？

zhunan0720

各路大神，本人小白，刚接触VBA。现在有个文件需要处理，要求查找“商品名称”与“型号”相同的所有行里，“原价”+“利润”最大的那个行，并将这行内容输出到一个新建的工作表中。如出现“原价”+“利润”相等，则输出第一次出现的那行数据。本人用我拙劣的方法，写了写代码但运行死机，不知道是不是死循环，还是系统资源消耗殆尽造成的，求大神们指导。代码如下：
Sub 求忙时()
Dim Brr(1 To 10000, 1 To 1000) '构造一个数组，行数足够多'
Dim i '定义变量行数和列数'
Dim lie, l As Byte
Dim arr, x As Long, sr As String, k, m As Integer
Set d = CreateObject("scripting.dictionary") '创建一个字典,
k = 1
arr = Sheets("原始数据").UsedRange '将数据区域输入数组'
For x = 1 To UBound(arr) '在数组内部循环
sr = arr(x, 1) & "-" & arr(x, 2) '因为是两个条件做关键字，需要将两列内容联合'
If d.Exists(sr) Then '如果关键字存在就累加数据
i = d(sr) '条目是行数
lie = 3
m = arr(i, 3) + arr(i, 4)
n = Brr(k, 3) + Brr(k, 4)
Do While lie <= UBound(arr, 2)
If m > n Then
Brr(k, lie) = arr(i, lie) '最大值写入数组'
lie = lie + 1
end if
Loop
Else
k = k + 1 '如果关键字不存在计数器加1'
d(sr) = k '将关键字的条目设为行数，方便以后取数
Brr(k, 1) = arr(x, 1) '将数据区域的前两个输入到Brr数组
Brr(k, 2) = arr(x, 2)
l = 3
Do While l <= UBound(arr, 2)
Brr(k, l) = arr(x, l) '将数据区域的其他数据输入到Brr数组
l = l + 1
Loop
End If
Next x
l = UBound(arr, 2)
Worksheets.Add
  Range("a1").Resize(k, l) = Brr '将Brr数组导入到单元格'
  Set arr = Nothing
End Sub

wolfxin2010

看你的数据是不是原价最高那一行提取出来？你还是加我微信：我帮你搞定

wolfxin2010

微信名与我的网名一致！！！！

wolfxin2010

写好了，你看看，希望对你有帮助！！！ 提取同商品型号利润最高.zip (128.7 KB, 下载次数: 3)

2018-5-2 11:27 上传

点击文件名下载附件
傻瓜式地提取同商品型号利润最高

zhunan0720

多谢，后来我实在憋得不行了，用SQL语句解决了，VBA数组限制太多。