[已解决]求一段明细清单的代码

liangnan1986

求明细清单的代码.rar (14.53 KB, 下载次数: 12)

2011-11-13 20:17 上传

点击文件名下载附件
要求见表内

最佳答案

月排行榜 / 总排行榜

wayy

2011-11-14 13:41

1. Private Sub CommandButton1_Click()
   
2. Dim i As Long
   
3. Dim h As Long
   
4. Dim xm As String
   
5. xm = [b2].Value
   
6. Dim arr1, arr2
   
7. With Sheet5
   
8. arr1 = .Range("C2", .[N65536].End(xlUp))
   
9. End With
   
10. ReDim arr2(1 To UBound(arr1), 1 To 11)
    
11. For i = 1 To UBound(arr1)
    
12.     If arr1(i, 5) = xm And arr1(i, 2) <> "A" And arr1(i, 2) <> "B" Then
    
13.        h = h + 1
    
14.        arr2(h, 1) = arr1(i, 1)
    
15.        arr2(h, 2) = arr1(i, 2)
    
16.        arr2(h, 3) = arr1(i, 3)
    
17.        arr2(h, 4) = arr1(i, 4)
    
18.        arr2(h, 5) = arr1(i, 6)
    
19.        arr2(h, 6) = arr1(i, 8)
    
20.        arr2(h, 7) = arr1(i, 9)
    
21.        arr2(h, 8) = arr1(i, 10)
    
22.        arr2(h, 9) = arr1(i, 11)
    
23.        arr2(h, 10) = arr1(i, 12)
    
24.     If h = 1 Then
    
25.       arr2(h, 11) = arr1(i, 8) * 1 - arr1(i, 12) * 1
    
26.     Else
    
27.       arr2(h, 11) = arr1(i, 8) - arr1(i, 12) + arr2(h - 1, 11)
    
28.     End If
    
29.     End If
    
30. Next
    
31. Sheet6.Select
    
32. Range("A4:K65536").ClearContents
    
33. Range("A4").Resize(h, 11) = arr2
    
34. MsgBox "数据提取完毕！！", , "wayy提示您"
    
35. End Sub

复制代码

这个完全可以自己加下，不要把全部的要求都让别人给完成，自己却不会，以后改还是需要自己去学着改的。
PS:授人以渔比授人以鱼更重要。

跳转到最佳答案楼层

wayy

求明细清单的代码wayy.rar (19.55 KB, 下载次数: 18)

2011-11-14 10:10 上传

点击文件名下载附件

代码不难，时间真不容易。

liangnan1986

wayy 发表于 2011-11-14 10:10
代码不难，时间真不容易。

谢谢版主，大部份要求实现了，但是还有一个要求：提取的内容，库别列里不要A或B的内容

wayy

1. Private Sub CommandButton1_Click()
   
2. Dim i As Long
   
3. Dim h As Long
   
4. Dim xm As String
   
5. xm = [b2].Value
   
6. Dim arr1, arr2
   
7. With Sheet5
   
8. arr1 = .Range("C2", .[N65536].End(xlUp))
   
9. End With
   
10. ReDim arr2(1 To UBound(arr1), 1 To 11)
    
11. For i = 1 To UBound(arr1)
    
12.     If arr1(i, 5) = xm And arr1(i, 2) <> "A" And arr1(i, 2) <> "B" Then
    
13.        h = h + 1
    
14.        arr2(h, 1) = arr1(i, 1)
    
15.        arr2(h, 2) = arr1(i, 2)
    
16.        arr2(h, 3) = arr1(i, 3)
    
17.        arr2(h, 4) = arr1(i, 4)
    
18.        arr2(h, 5) = arr1(i, 6)
    
19.        arr2(h, 6) = arr1(i, 8)
    
20.        arr2(h, 7) = arr1(i, 9)
    
21.        arr2(h, 8) = arr1(i, 10)
    
22.        arr2(h, 9) = arr1(i, 11)
    
23.        arr2(h, 10) = arr1(i, 12)
    
24.     If h = 1 Then
    
25.       arr2(h, 11) = arr1(i, 8) * 1 - arr1(i, 12) * 1
    
26.     Else
    
27.       arr2(h, 11) = arr1(i, 8) - arr1(i, 12) + arr2(h - 1, 11)
    
28.     End If
    
29.     End If
    
30. Next
    
31. Sheet6.Select
    
32. Range("A4:K65536").ClearContents
    
33. Range("A4").Resize(h, 11) = arr2
    
34. MsgBox "数据提取完毕！！", , "wayy提示您"
    
35. End Sub

复制代码

这个完全可以自己加下，不要把全部的要求都让别人给完成，自己却不会，以后改还是需要自己去学着改的。
PS:授人以渔比授人以鱼更重要。