如何用代码把欠款明细全部复制到打印欠款中，然后筛选余额一列中的负值后，把大于...

zhiaizhi520

1、如何用代码把欠款明细全部复制到打印欠款中，然后筛选余额一列中的负值后，把大于等于零值的数据删除

3、本人用录制宏做了一下，求大神帮忙优化代码？

lenghonghai601

1. Sub test()
   
2. Dim i%, arr, brr(), m%, j%
   
3. arr = Sheet1.Range("a1").CurrentRegion
   
4. ReDim brr(1 To UBound(arr), 1 To 8)
   
5. For i = 2 To UBound(arr)
   
6.     If Val(arr(i, 8)) < 0 Then
   
7.         m = m + 1
   
8.         For j = 1 To 8
   
9.             brr(m, j) = arr(i, j)
   
10.         Next j
    
11.     End If
    
12. Next i
    
13. Sheet2.Cells.ClearContents
    
14. Sheet2.Range("a2").Resize(m, 8) = brr
    
15. Sheet1.Range("a1").Resize(1, 8).Copy Sheet2.Range("a1")
    
16. End Sub
    

复制代码

lsc900707

用数组一步到位：

1. Sub gj23w98()
   
2.     arr = Sheet1.[a1].CurrentRegion
   
3.     m = UBound(arr): n = UBound(arr, 2)
   
4.     ReDim brr(1 To m, 1 To n)
   
5.     For i = 2 To m
   
6.         If arr(i, 8) < 0 Then
   
7.             k = k + 1
   
8.             For j = 1 To n
   
9.                 brr(k, j) = arr(i, j)
   
10.             Next
    
11.         End If
    
12.     Next
    
13.     If k Then
    
14.         [a1].CurrentRegion.Offset(1).ClearContents
    
15.         [a2].Resize(k, UBound(brr, 2)) = brr
    
16.     End If
    
17. End Sub
    

复制代码

lsc900707

参考附件：

zhiaizhi520

lsc900707 发表于 2018-7-7 19:28
用数组一步到位：

感谢！代码很完美...不好意思，昨天例子中没表述明白，欠款明细相当于数据库，客户有重复采购和订购，故用透视表透视处理后筛选出有欠款的客户来打印。望大神帮忙修改一下...

lsc900707

zhiaizhi520 发表于 2018-7-8 15:53
感谢！代码很完美...不好意思，昨天例子中没表述明白，欠款明细相当于数据库，客户有重复采购和订购，故 ...

1. Sub gj23w98()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = Sheet1.[a1].CurrentRegion
   
4.     m = UBound(arr): n = UBound(arr, 2)
   
5.     ReDim brr(1 To m, 1 To n)
   
6.     For i = 2 To m
   
7.         s = arr(i, 1)
   
8.         If arr(i, 8) < 0 Then
   
9.             If d(s) = "" Then
   
10.                 k = k + 1: d(s) = k: brr(k, 1) = s
    
11.                 For j = 2 To n
    
12.                     brr(k, j) = arr(i, j)
    
13.                 Next
    
14.             Else
    
15.                 For j = 4 To n
    
16.                     If Len(arr(i, j)) Then
    
17.                         brr(d(s), j) = brr(d(s), j) + arr(i, j)
    
18.                     End If
    
19.                 Next
    
20.             End If
    
21.         End If
    
22.     Next
    
23.     If k Then
    
24.         [a1].CurrentRegion.Offset(1).ClearContents
    
25.         [a2].Resize(k, UBound(brr, 2)) = brr
    
26.     End If
    
27. End Sub

复制代码

lsc900707

zhiaizhi520 发表于 2018-7-8 15:53
感谢！代码很完美...不好意思，昨天例子中没表述明白，欠款明细相当于数据库，客户有重复采购和订购，故 ...

附件供测试参考：