[已解决]怎么提取符合条件的数据？？

wwt6080

2012年物资明细账仅出库.zip (82.52 KB, 下载次数: 13)

2013-1-7 09:54 上传

点击文件名下载附件

把进销记录工作表里面符合出库的数据，提取到仅出库工作表

仅出库工作表可以按月份查询。仅出库工作表日期只要显示年月日的几日就可以。

最佳答案

月排行榜 / 总排行榜

suye1010

2013-1-7 13:16

1. Sub Outbound()
   
2. Dim arr0, arr1, arr2, arr3, i As Integer
   
3. arr0 = Sheets("进销记录").UsedRange
   
4. On Error Resume Next
   
5. arr1 = Application.Transpose(Array("商品编码", "商品名称", "日期", "出库"))
   
6. arr2 = Application.Transpose(Array("商品编码", "商品名称", "日期", "出库"))
   
7. arr3 = Application.Transpose(Array("商品编码", "商品名称", "日期", "出库"))
   
8. For i = 2 To UBound(arr0)
   
9.     If arr0(i, 3) = "出库" And arr0(i, 1) <> "" And arr0(i, 14) <> "" And Month(DateValue(arr0(i, 1))) = Val(Sheets("仅出库").Cells(1, 2)) Then
   
10.         Select Case arr0(i, 4)
    
11.             Case Sheets("仅出库").Cells(2, 2)
    
12.                 ReDim Preserve arr1(1 To 4, 1 To UBound(arr1, 2) + 1)
    
13.                 arr1(1, UBound(arr1, 2)) = arr0(i, 14)
    
14.                 arr1(2, UBound(arr1, 2)) = arr0(i, 15)
    
15.                 arr1(3, UBound(arr1, 2)) = Day(DateValue(arr0(i, 1)))
    
16.                 arr1(4, UBound(arr1, 2)) = arr0(i, 11)
    
17.             Case Sheets("仅出库").Cells(2, 6)
    
18.                 ReDim Preserve arr2(1 To 4, 1 To UBound(arr2, 2) + 1)
    
19.                 arr2(1, UBound(arr2, 2)) = arr0(i, 14)
    
20.                 arr2(2, UBound(arr2, 2)) = arr0(i, 15)
    
21.                 arr2(3, UBound(arr2, 2)) = Day(DateValue(arr0(i, 1)))
    
22.                 arr2(4, UBound(arr2, 2)) = arr0(i, 11)
    
23.             Case Sheets("仅出库").Cells(2, 10)
    
24.                 ReDim Preserve arr3(1 To 4, 1 To UBound(arr3, 2) + 1)
    
25.                 arr3(1, UBound(arr3, 2)) = arr0(i, 14)
    
26.                 arr3(2, UBound(arr3, 2)) = arr0(i, 15)
    
27.                 arr3(3, UBound(arr3, 2)) = Day(DateValue(arr0(i, 1)))
    
28.                 arr3(4, UBound(arr3, 2)) = arr0(i, 11)
    
29.         End Select
    
30.     End If
    
31. Next i
    
32. Sheets("仅出库").Cells(3, 1).Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
    
33. Sheets("仅出库").Cells(3, 5).Resize(UBound(arr2, 2), UBound(arr2)) = Application.Transpose(arr2)
    
34. Sheets("仅出库").Cells(3, 9).Resize(UBound(arr3, 2), UBound(arr3)) = Application.Transpose(arr3)
    
35. End Sub

复制代码

跳转到最佳答案楼层

suye1010

1. Sub Outbound()
   
2. Dim arr0, arr1, arr2, arr3, i As Integer
   
3. arr0 = Sheets("进销记录").UsedRange
   
4. On Error Resume Next
   
5. arr1 = Application.Transpose(Array("商品编码", "商品名称", "日期", "出库"))
   
6. arr2 = Application.Transpose(Array("商品编码", "商品名称", "日期", "出库"))
   
7. arr3 = Application.Transpose(Array("商品编码", "商品名称", "日期", "出库"))
   
8. For i = 2 To UBound(arr0)
   
9.     If arr0(i, 3) = "出库" And arr0(i, 1) <> "" And arr0(i, 14) <> "" And Month(DateValue(arr0(i, 1))) = Val(Sheets("仅出库").Cells(1, 2)) Then
   
10.         Select Case arr0(i, 4)
    
11.             Case Sheets("仅出库").Cells(2, 2)
    
12.                 ReDim Preserve arr1(1 To 4, 1 To UBound(arr1, 2) + 1)
    
13.                 arr1(1, UBound(arr1, 2)) = arr0(i, 14)
    
14.                 arr1(2, UBound(arr1, 2)) = arr0(i, 15)
    
15.                 arr1(3, UBound(arr1, 2)) = Day(DateValue(arr0(i, 1)))
    
16.                 arr1(4, UBound(arr1, 2)) = arr0(i, 11)
    
17.             Case Sheets("仅出库").Cells(2, 6)
    
18.                 ReDim Preserve arr2(1 To 4, 1 To UBound(arr2, 2) + 1)
    
19.                 arr2(1, UBound(arr2, 2)) = arr0(i, 14)
    
20.                 arr2(2, UBound(arr2, 2)) = arr0(i, 15)
    
21.                 arr2(3, UBound(arr2, 2)) = Day(DateValue(arr0(i, 1)))
    
22.                 arr2(4, UBound(arr2, 2)) = arr0(i, 11)
    
23.             Case Sheets("仅出库").Cells(2, 10)
    
24.                 ReDim Preserve arr3(1 To 4, 1 To UBound(arr3, 2) + 1)
    
25.                 arr3(1, UBound(arr3, 2)) = arr0(i, 14)
    
26.                 arr3(2, UBound(arr3, 2)) = arr0(i, 15)
    
27.                 arr3(3, UBound(arr3, 2)) = Day(DateValue(arr0(i, 1)))
    
28.                 arr3(4, UBound(arr3, 2)) = arr0(i, 11)
    
29.         End Select
    
30.     End If
    
31. Next i
    
32. Sheets("仅出库").Cells(3, 1).Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
    
33. Sheets("仅出库").Cells(3, 5).Resize(UBound(arr2, 2), UBound(arr2)) = Application.Transpose(arr2)
    
34. Sheets("仅出库").Cells(3, 9).Resize(UBound(arr3, 2), UBound(arr3)) = Application.Transpose(arr3)
    
35. End Sub

复制代码

wwt6080

suye1010 发表于 2013-1-7 13:16

{:031:}不能下载。。下载是错误格式。。下载一个这个forum.php。。。还被扣了1金币。。

小蚊子