浏览了你的代码,100多行了,很不错的,我粘贴一份在下面,以供其他人查看方便,你有具体问题可以针对性的讨论。
程序代码:
Sub 制作站位表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim F, i, n, ar, arr, brr(1 To 5000, 1 To 8), wb As Workbook, rng As Range, d As Object, sht As Worksheet
Set d = CreateObject("scripting.dictionary")
F = Application.GetOpenFilename("导入BOM,*.xlsx;*.xls", MultiSelect:=True)
Set wb = Workbooks.Open(F(1))
ar = ActiveSheet.UsedRange
wb.Close False
F = Application.GetOpenFilename("导入站位表文件,*.csv", MultiSelect:=True)
Set wb = Workbooks.Open(F(1))
arr = ActiveSheet.UsedRange
wb.Close False
For i = 7 To UBound(arr) '机器名
If arr(i, 1) <> "" Then d(Val(arr(i, 1))) = ""
Next
For Each sht In Sheets
If sht.Name <> "站位表工具" Then sht.Delete
Next
For K = 0 To d.Count - 1
For i = 7 To UBound(arr)
If arr(i, 1) = d.keys()(K) And arr(i, 3) <> "2" And arr(i, 6) <> "" Then
n = n + 1
brr(n, 1) = n '序号
If arr(i, 5) <> "" Then
brr(n, 2) = Right(arr(i, 4), 2) & "-" & arr(i, 5) '栈位号
Else
brr(n, 2) = Right(arr(i, 4), 2) '栈位号
End If
brr(n, 3) = Left(arr(i, 6), 10) '物料编码
brr(n, 5) = arr(i, 8) '飞达规格
If arr(i, 12) <> "" Then
brr(n, 8) = arr(i, 12) '位号
brr(n, 7) = UBound(Split(arr(i, 12), ",")) + 1 '用量
End If
If arr(i, 13) <> "" Then
brr(n, 8) = arr(i, 13) '位号
brr(n, 7) = UBound(Split(arr(i, 13), ",")) + 1 '用量
End If
For r = 8 To UBound(ar)
If ar(r, 2) = brr(n, 3) Then
brr(n, 4) = ar(r, 5) '元件名称
If ar(r, 11) <> "" Then
brr(n, 6) = "Y" '是否主料
Else
brr(n, 6) = "N"
End If
End If
Next
End If
Next
Rows("6:5000").Delete
[A6].Resize(UBound(brr), 8) = brr
n = 0: Erase brr
' Range("a6:h" & [a65536].End(3).Row).HorizontalAlignment = Excel.xlCenter '左右居中
' Range("a6:h" & [a65536].End(3).Row).VerticalAlignment = xlCenter '上下居中
Range("a6:h" & [a65536].End(3).Row).Borders.LineStyle = xlContinuous '添加边框
Sheets("站位表工具").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes.Range(Array("Button 1")).Delete
ActiveSheet.Name = "机台" & d.keys()(K) & "-TAB1"
Next
For M = 0 To d.Count - 1
For i = 7 To UBound(arr)
If arr(i, 1) = d.keys()(M) And arr(i, 3) <> "2" And arr(i, 6) <> "" Then
n = n + 1
brr(n, 1) = n '序号
If arr(i, 5) <> "" Then
brr(n, 2) = Right(arr(i, 4), 2) & "-" & arr(i, 5) '栈位号
Else
brr(n, 2) = Right(arr(i, 4), 2) '栈位号
End If
brr(n, 3) = Left(arr(i, 6), 10) '物料编码
brr(n, 5) = arr(i, 8) '飞达规格
If arr(i, 12) <> "" Then
brr(n, 8) = arr(i, 12) '位号
brr(n, 7) = UBound(Split(arr(i, 12), ",")) + 1 '用量
End If
If arr(i, 13) <> "" Then
brr(n, 8) = arr(i, 13) '位号
brr(n, 7) = UBound(Split(arr(i, 13), ",")) + 1 '用量
End If
For r = 8 To UBound(ar)
If ar(r, 2) = brr(n, 3) Then
brr(n, 4) = ar(r, 5) '元件名称
If ar(r, 11) <> "" Then
brr(n, 6) = "Y" '是否主料
Else
brr(n, 6) = "N"
End If
End If
Next
End If
Next
Rows("6:1000").Delete
[A6].Resize(UBound(brr), 8) = brr
n = 0: Erase brr
' Range("a6:h" & [a65536].End(3).Row).HorizontalAlignment = Excel.xlCenter '左右居中
' Range("a6:h" & [a65536].End(3).Row).VerticalAlignment = xlCenter '上下居中
Range("a6:h" & [a65536].End(3).Row).Borders.LineStyle = xlContinuous '添加边框
Sheets("站位表工具").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes.Range(Array("Button 1")).Delete
ActiveSheet.Name = "机台" & d.keys()(M) & "-TAB2"
Next
MsgBox "站位表制作完成!", 48, "温馨提示"
End Sub