这个谁会做？VBA实现，有鲜花！

约定的童话

文件内代码作废！

凌空一羽

Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If strfile = "" Then Exit Sub
With Workbooks.Open(strfile)
    ar = .Sheets(1).Range("a1").CurrentRegion
    .Close 0
End With
ReDim br(1 To 1000, 1 To 2)
For i = 2 To UBound(ar)
    If Len(ar(i, 5)) Then
        For j = 0 To UBound(Split(ar(i, 5), ","))
            n = n + 1
            br(n, 1) = ar(i, 2)
            br(n, 2) = Split(ar(i, 5), ",")(j)
        Next
    End If
Next
Cells.ClearContents
Range("a1").Resize(n, 2) = br
End Sub

约定的童话

凌空一羽 发表于 2018-8-9 17:55
Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If strfi ...

6666，大神，那个（i，5）这种能改成关键字吗？因为列数不固定，有时候在Z列有时候在E列，反正就是不固定那种，前面那个（i,2）也是

kings12333

BOM清单，看来又是一个搞SMT行业的人士，其实有好多现成的，比如於成有写过一个EXCEL生成YAMAHA\JUKI\松下的EXCEL宏。。。还带BOM与CAD合并的功能哦。。。

凌空一羽

约定的童话 发表于 2018-8-9 18:03
6666，大神，那个（i，5）这种能改成关键字吗？因为列数不固定，有时候在Z列有时候在E列，反正就是不固定 ...

Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If strfile = "" Then Exit Sub
With Workbooks.Open(strfile)
    ar = .Sheets(1).Range("a1").CurrentRegion
    L元件品号 = .Sheets(1).Rows(1).Find("元件品号", , , xlWhole).Column
    L位置 = .Sheets(1).Rows(1).Find("位置", , , xlWhole).Column
    .Close 0
End With
ReDim br(1 To 1000, 1 To 2)
For i = 2 To UBound(ar)
    If Len(ar(i, L位置)) Then
        For j = 0 To UBound(Split(ar(i, L位置), ","))
            n = n + 1
            br(n, 1) = ar(i, L元件品号)
            br(n, 2) = Split(ar(i, L位置), ",")(j)
        Next
    End If
Next
Cells.ClearContents
Range("a1").Resize(n, 2) = br
End Sub

约定的童话

kings12333 发表于 2018-8-9 18:05
BOM清单，看来又是一个搞SMT行业的人士，其实有好多现成的，比如於成有写过一个EXCEL生成YAMAHA\JUKI\松下 ...

哈哈，这都让你看出来了，你说的那个试过了，不通用，还是自己做的实用一点！

约定的童话

凌空一羽 发表于 2018-8-9 18:09
Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If str ...

大神，我把代码关键字改了，为啥导入另外一个文件就不行了啊？
https://pan.baidu.com/s/1QpqXabNpKkMJf11V2Yl6ZQ文件在这里

凌空一羽

约定的童话 发表于 2018-8-9 18:49
大神，我把代码关键字改了，为啥导入另外一个文件就不行了啊？
https://pan.baidu.com/s/1QpqXabNpKkMJf ...

Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If strfile = "" Then Exit Sub
With Workbooks.Open(strfile)
    ar = .Sheets(1).UsedRange
    L元件品号 = .Sheets(1).Rows(1).Find("编号", , , xlWhole).Column
    L位置 = .Sheets(1).Rows(1).Find("位号", , , xlWhole).Column
    .Close 0
End With
ReDim br(1 To 1000, 1 To 2)
For i = 2 To UBound(ar)
    If Len(ar(i, L位置)) Then
        If Right(ar(i, L位置), 1) = "," Then x = Left(ar(i, L位置), Len(ar(i, L位置)) - 1) Else x = ar(i, L位置)
        For j = 0 To UBound(Split(x, ","))
            n = n + 1
            br(n, 1) = ar(i, L元件品号)
            br(n, 2) = Split(ar(i, L位置), ",")(j)
        Next
    End If
Next
Cells.ClearContents
Range("a1").Resize(n, 2) = br
End Sub

凌空一羽

约定的童话 发表于 2018-8-9 18:49
大神，我把代码关键字改了，为啥导入另外一个文件就不行了啊？
https://pan.baidu.com/s/1QpqXabNpKkMJf ...

见附件………………

chaohuahch

1. Sub fyExcelVBA2()
   
2. 
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. Dim arr, brr(), i%, j%, n%
   
6. Dim path1$, pathName$
   
7. path1 = ThisWorkbook.path
   
8. pathName = "常规BOM.xls"
   
9. 
   
10. With Workbooks.Open(path1 & "" & pathName)
    
11. arr = .Sheets(1).Range("a1").CurrentRegion
    
12. .Close 0
    
13. End With
    
14. 
    
15. For i = 1 To UBound(arr, 2)
    
16.    If arr(1, i) = "元件品号" Then m = i
    
17.    If arr(1, i) = "位置" Then mm = i
    
18. Next i
    
19. 
    
20. ReDim brr(1 To UBound(arr) * 3, 1 To 2)
    
21.   For i = 2 To UBound(arr)
    
22.   If Len(arr(i, m)) Then
    
23.      For j = 0 To UBound(Split(arr(i, mm), ","))
    
24.       n = n + 1
    
25.       brr(n, 1) = arr(i, m)
    
26.       brr(n, 2) = Split(arr(i, mm), ",")(j)
    
27.      Next j
    
28.   End If
    
29.   Next i
    
30. With Sheets("BOM文件")
    
31.    .Cells.ClearContents
    
32.    .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
33. End With
    
34. Application.DisplayAlerts = True
    
35. Application.ScreenUpdating = True
    
36. 
    
37. End Sub
    
38. 
    

复制代码