[已解决]提取工作薄里指定列里小于零的数据

salt

求助：提取《附表四：甲供物资汇总表》里竣工数量减出库数量那列小于零的数据连同名称、规格型号、单位、单价一起复制到《施工单位遗失材料价值清单》这张表里，自动合计，（注明：竣工数量-出库数量那列是不固定的），详见附件。

最佳答案

月排行榜 / 总排行榜

dsmch

2015-1-6 12:53

1. Sub Macro1()
   
2. Dim arr, brr, wb As Workbook, i&, s&
   
3. Application.ScreenUpdating = False
   
4. With GetObject(ThisWorkbook.Path & "\物质增减表\附表四：甲供物资汇总表.xls")
   
5.     arr = .Sheets(1).UsedRange
   
6.     Set rng = .Sheets(1).Cells.Find("竣工数量—出库数量")
   
7.     If Not rng Is Nothing Then l = rng.Column
   
8.     .Close 0
   
9. End With
   
10. ReDim brr(1 To UBound(arr), 1 To 8)
    
11. For i = 4 To UBound(arr)
    
12.     If arr(i, l) < 0 Then
    
13.         s = s + 1
    
14.         brr(s, 1) = s
    
15.         brr(s, 2) = arr(i, 2)
    
16.         brr(s, 3) = arr(i, 3)
    
17.         brr(s, 4) = arr(i, 4)
    
18.         brr(s, 5) = Abs(arr(i, l))
    
19.         brr(s, 6) = arr(i, l - 1)
    
20.         brr(s, 7) = Abs(arr(i, l + 1))
    
21.         n = n + brr(s, 7)
    
22.     End If
    
23. Next
    
24. brr(s + 1, 2) = "合计": brr(s + 1, 7) = n
    
25. Range("a4").Resize(s + 1, 8) = brr
    
26. Application.ScreenUpdating = True
    
27. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, wb As Workbook, i&, s&
   
3. Application.ScreenUpdating = False
   
4. With GetObject(ThisWorkbook.Path & "\物质增减表\附表四：甲供物资汇总表.xls")
   
5.     arr = .Sheets(1).UsedRange
   
6.     Set rng = .Sheets(1).Cells.Find("竣工数量—出库数量")
   
7.     If Not rng Is Nothing Then l = rng.Column
   
8.     .Close 0
   
9. End With
   
10. ReDim brr(1 To UBound(arr), 1 To 8)
    
11. For i = 4 To UBound(arr)
    
12.     If arr(i, l) < 0 Then
    
13.         s = s + 1
    
14.         brr(s, 1) = s
    
15.         brr(s, 2) = arr(i, 2)
    
16.         brr(s, 3) = arr(i, 3)
    
17.         brr(s, 4) = arr(i, 4)
    
18.         brr(s, 5) = Abs(arr(i, l))
    
19.         brr(s, 6) = arr(i, l - 1)
    
20.         brr(s, 7) = Abs(arr(i, l + 1))
    
21.         n = n + brr(s, 7)
    
22.     End If
    
23. Next
    
24. brr(s + 1, 2) = "合计": brr(s + 1, 7) = n
    
25. Range("a4").Resize(s + 1, 8) = brr
    
26. Application.ScreenUpdating = True
    
27. End Sub

复制代码