BOM表如何拆分

y1983y

各位大侠：您们好！       由于工作需要，要将多个产品BOM表进行拆分，请各位大侠给予帮助。谢谢！

microyip

直接对F~AC列进行去空行处理就是你要的结果啦，循环一下列，再循环行来比对就是了

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("bom")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
11.     arr = .Range("a1").Resize(r, c)
    
12.     For j = 6 To UBound(arr, 2) - 3
    
13.       Set d(arr(1, j)) = Union(.Cells(1, 1).Resize(r, 5), .Cells(1, j).Resize(r, 1), .Cells(1, UBound(arr, 2) - 2).Resize(r, 3))
    
14.     Next
    
15.   End With
    
16.   For Each aa In d.keys
    
17.     On Error Resume Next
    
18.     Set ws = Worksheets(aa)
    
19.     If Err Then
    
20.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
21.       ws.Name = aa
    
22.     End If
    
23.     On Error GoTo 0
    
24.     With ws
    
25.       .Cells.Clear
    
26.       d(aa).Copy .Range("a1")
    
27.       .Range("f1:f" & r).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
28.     End With
    
29.   Next
    
30. End Sub
    

复制代码

chxw68

该题目使用字典有点多余了。

yooha

Bom表拆分.zip (130.17 KB, 下载次数: 26)

2019-6-25 15:41 上传

点击文件名下载附件

见附件

yooha

Sub test()
Dim aa1, aa2, sz1, sz2(1 To 60000, 1 To 9), bb1, bb2
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
For aa1 = Sheets.Count To 2 Step -1
Sheets(aa1).Delete
Next
End If
aa1 = Sheet1.Cells(Rows.Count, 1).End(3).Row
aa2 = Sheet1.Cells(1, Columns.Count).End(1).Column
sz1 = Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(aa1, aa2))
For aa1 = 1 To UBound(sz1, 2)
If sz1(1, aa1) Like "V*" Then
Sheets.Add.Name = sz1(1, aa1)
Sheets(sz1(1, aa1)).Move After:=Sheets(Sheets.Count)
bb1 = 0
For aa2 = 1 To UBound(sz1)
If sz1(aa2, aa1) <> Empty Then
bb1 = bb1 + 1
For bb2 = 1 To 5
sz2(bb1, bb2) = sz1(aa2, bb2)
Next
sz2(bb1, 6) = sz1(aa2, aa1)
For bb2 = 7 To 9
sz2(bb1, bb2) = sz1(aa2, bb2 + 23)
Next
End If
Next
If sz2(1, 1) <> Empty Then
Sheets(sz1(1, aa1)).Range(Sheets(sz1(1, aa1)).Cells(1, 1), Sheets(sz1(1, aa1)).Cells(bb1, 9)) = sz2
Sheets(sz1(1, aa1)).Range(Sheets(sz1(1, aa1)).Cells(1, 1), Sheets(sz1(1, aa1)).Cells(bb1, 9)).Borders.LineStyle = xlContinuous
End If
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

y1983y

microyip 发表于 2019-6-25 14:34
直接对F~AC列进行去空行处理就是你要的结果啦，循环一下列，再循环行来比对就是了

谢谢，是个思路

y1983y

朱荣兴 发表于 2019-6-25 14:52
Sub chaifen() '''QQ:705664849
Application.DisplayAlerts = False
    For Each sh In Sheets

很精炼，谢谢！

y1983y

chxw68 发表于 2019-6-25 15:09
该题目使用字典有点多余了。

厉害了，谢谢侠圣