BOM产成品与子项的批量提取

alanlad

老师好


我遇到个问题就是想从ERP导出的BOM中把数据编程一维表格，不知道怎么用VBA代码达到 打印BOM子表.rar (16.93 KB, 下载次数: 3)

2023-2-2 09:50 上传

点击文件名下载附件

原始表：

要达到的效果：

chxw68

1. Sub test()
   
2.     Dim r%, i%, m%
   
3.     Dim arr, brr, zrr()
   
4.     With Worksheets("新的工作表")
   
5.         r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
6.         c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
   
7.         arr = .Range("a1").Resize(r, c)
   
8.     End With
   
9.     m = 0
   
10.     For i = 1 To UBound(arr)
    
11.         If arr(i, 1) = "计划组织：" Then
    
12.             m = m + 1
    
13.             ReDim Preserve zrr(1 To m)
    
14.             zrr(m) = Array(i, i)
    
15.         Else
    
16.             If m > 0 Then
    
17.                 zrr(m)(1) = i
    
18.             End If
    
19.         End If
    
20.     Next
    
21.     ReDim brr(1 To UBound(arr), 1 To 6)
    
22.     m = 0
    
23.     For k = 1 To UBound(zrr)
    
24.         For i = zrr(k)(0) To zrr(k)(1)
    
25.             If arr(i, 1) Like "#*" Then
    
26.                 m = m + 1
    
27.                 brr(m, 1) = arr(zrr(k)(0), 4)
    
28.                 brr(m, 2) = arr(zrr(k)(0), 6)
    
29.                 brr(m, 3) = arr(i, 2)
    
30.                 brr(m, 4) = arr(i, 3)
    
31.                 brr(m, 5) = arr(i, 8)
    
32.                 brr(m, 6) = arr(i, 10)
    
33.             End If
    
34.         Next
    
35.     Next
    
36.     With Worksheets("sheet1")
    
37.         .UsedRange.Offset(1, 0).Clear
    
38.         .Range("a:e").NumberFormatLocal = "@"
    
39.         .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
40.         With .UsedRange
    
41.             .HorizontalAlignment = xlCenter
    
42.             .VerticalAlignment = xlCenter
    
43.         End With
    
44.     End With
    
45. End Sub
    

复制代码

chxw68

详见附件。

ykcbf1100

数据提取。

chxw68

1. Sub test2()
   
2.     Dim r%, i%, m%
   
3.     Dim arr, brr
   
4.     With Worksheets("新的工作表")
   
5.         r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
6.         c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
   
7.         arr = .Range("a1").Resize(r, c)
   
8.     End With
   
9.     ReDim brr(1 To UBound(arr), 1 To 6)
   
10.     m = 0
    
11.     For i = 1 To UBound(arr)
    
12.         If arr(i, 1) = "计划组织：" Then
    
13.             bm = arr(i, 4)
    
14.             mc = arr(i, 6)
    
15.         ElseIf arr(i, 1) Like "#*" Then
    
16.             m = m + 1
    
17.             brr(m, 1) = bm
    
18.             brr(m, 2) = mc
    
19.             brr(m, 3) = arr(i, 2)
    
20.             brr(m, 4) = arr(i, 3)
    
21.             brr(m, 5) = arr(i, 8)
    
22.             brr(m, 6) = arr(i, 10)
    
23.         End If
    
24.     Next
    
25.     With Worksheets("sheet1")
    
26.         .UsedRange.Offset(1, 0).Clear
    
27.         .Range("a:e").NumberFormatLocal = "@"
    
28.         .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
29.         With .UsedRange
    
30.             .HorizontalAlignment = xlCenter
    
31.             .VerticalAlignment = xlCenter
    
32.         End With
    
33.     End With
    
34. End Sub
    
35. 
    

复制代码

chxw68

简化一下代码。

alanlad

ykcbf1100 发表于 2023-2-2 10:35
数据提取。

感谢老师，