请教：如何按要求提取内容并复制到另一工作薄

神往之地

请教用VBA达成如附件中想要的结果然后把结果自动复制到“BOM提取”工作薄中。
感谢老师指导！

idnoidno

1. Option Explicit
   
2. Sub tak()
   
3.   Dim myDic As Object, myKey, myItem
   
4.   Dim myVal, myVal2, myVal3
   
5.   Dim i As Long
   
6.       
   
7.     Set myDic = CreateObject("Scripting.Dictionary")   
   
8.     myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value
   
9.    
   
10.         For i = 1 To UBound(myVal, 1)
    
11.             myVal2 = myVal(i, 1) & "_" & "TerMinal"
    
12.             If Not myVal2 = "_" Then
    
13.                 If Not myDic.exists(myVal2) Then
    
14.                     myDic.Add myVal2, myVal(i, 4)
    
15.                 Else
    
16.                     myDic(myVal2) = myDic(myVal2) + myVal(i, 4)
    
17.                 End If
    
18.             End If
    
19.         Next
    
20.    
    
21.     myKey = myDic.keys
    
22.     myItem = myDic.items
    
23.     With Worksheets("BOM提取")
    
24.         .Range("a1:c1") = Array("母件編號", "子件名稱", "規格型號")
    
25.         For i = 0 To UBound(myKey)
    
26.             myVal3 = Split(myKey(i), "_")
    
27.             .Cells(i + 2, 1).Value = myVal3(0)
    
28.             .Cells(i + 2, 2).Value = myVal3(1)
    
29.             .Cells(i + 2, 3).Value = myItem(i)
    
30.         Next
    
31.     End With
    
32.     Set myDic = Nothing
    
33. End Sub
    

复制代码

chart888

1. Private Sub CommandButton1_Click()
   
2. Dim arr, brr(1 To 10000, 1 To 3)
   
3. Dim k&, m&, i&
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. 
   
6. arr = Worksheets("BOM").Range("A1:D" & Worksheets("BOM").Cells(Rows.Count, 1).End(3).Row)
   
7. For i = 2 To UBound(arr)
   
8.     If arr(i, 3) = "TerMinal" Then
   
9.         If d.Exists(arr(i, 1)) Then
   
10.             m = d(arr(i, 1))
    
11.             brr(m, 3) = brr(m, 3) & "," & arr(i, 4)
    
12.         Else
    
13.             k = k + 1
    
14.             d(arr(i, 1)) = k
    
15.             brr(k, 1) = arr(i, 1): brr(k, 2) = arr(i, 3)
    
16.             brr(k, 3) = arr(i, 4)
    
17.         End If
    
18.     End If
    
19. Next
    
20. Worksheets("BOM提取").Range("A2").Resize(d.Count, 3) = brr
    
21. End Sub

复制代码

lxmlb

下载不了附件。
参见excel插件工具——多簿多表合并Mergebooks.dll   ，里面有一个“跨表查询”功能，可以修改SQL语句，实行条件查询，应该能够满足你的要求。
具体下载地址：http://www.excelpx.com/thread-322290-1-1.html