Sub ReadBomFile()
Dim r As Long, c As Integer
Dim i As Long, j As Long, k As Long
Dim m As Integer, n As Integer
Dim PositionFlag As Integer
Dim lineCounts As Long, LineUbound As Long
Dim lines() As String, LinesArr() As String
Dim TitleArr() As String
Dim BomArr() As String
Dim BomTitleStartPosition As Integer, BomStartPosition As Integer
Dim BomRowCount As Long, BomColumnCount As Integer
Dim BomRowUbound As Long, BomColumnUbound As Integer
Dim BomPartNumber As Integer
Dim BomOnePartRows As Integer
Dim bomOnePartFlag As Boolean
Dim BomPartArr() As String
Dim StoreArr() As String
Dim StoreLastRow As Long
Dim StoreLastColumn As Integer
Dim Store As Variant
Dim BomFoundFlag As Boolean
Dim BomNotFoundRows As Integer
Dim BomFoundValue As String
Dim BomNotFoundArr() As String
Dim BomBuildArr() As String
'---------------------------------------打开BOM文件------------------------------------------------------
Dim Filt As String
Dim FilterIndex As Integer
Dim FilterTitle As String
Dim FileName As Variant
' set up list of file filters
Filt = "BOM Files (*.BOM),*.BOM," & _
"All Files (*.*),*.*"
' Display *.BOM by default
FilterIndex = 1
' Set the dialog box caption
Title = "select a File to Import"
' Get the file name
FileName = Application.GetOpenFilename _
(FileFilter:=Filt, _
FilterIndex:=FilterIndex, _
Title:=FilterTitle)
' Exit if dialog box canceled
If FileName = False Then
MsgBox "No file was selectd."
Exit Sub
End If
FileNameOnly = Split(Dir(FileName), ".")(0)
'----------------------------------------打开BOM文件-----------------------------------------------------
' On Error Resume Next
' Filename = GetImportFileName()
' Diplay line count of file
' LineCounts = GetFileLinesCount(Filename)
' MsgBox ("Total lines count: " & LineCounts)
'----------------------------------------读取BOM文件-----------------------------------------------------
Open FileName For Input As #1
If Err <> 0 Then
MsgBox "Not found: " & FileName, vbCritical, "Error"
Exit Sub
End If
lines = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
Close #1
LineUbound = UBound(lines)
lineCounts = UBound(lines) + 1
Application.ScreenUpdating = False
Sheets("BOM").Activate
Sheets("BOM").Range("A1").Activate
Sheets("BOM").UsedRange.ClearContents
'初始化变量
If lines(0) <> "" Then
r = 2
Else:
r = 0
End If
c = 0
n = 0
'处理BOM文件的开头部分
For i = 0 To 14
LinesArr = Split(lines(i), vbTab)
For j = 0 To UBound(LinesArr)
ActiveCell.Offset(r, c) = LinesArr(j)
c = c + 1
Next j
If InStr(lines(i), "Bill Of Materials") > 0 Then
PositionFlag = i 'n记录Bill Of Materials所处的位置（行数）
ActiveCell.Offset(r, 1).ClearContents '清除"Page 1"字样
Exit For
End If
r = r + 1
c = 0
Next i
'把BOM中的数据读入BomArr()数组中
BomTitleStartPosition = PositionFlag + 2 '指在Lines()数组中的下标
BomStartPosition = BomTitleStartPosition + 3
' MsgBox ("BomTitleStartPositon = " & BomTitleStartPosition)
TitleArr = Split(lines(BomTitleStartPosition), vbTab)
BomRowUbound = LineUbound - BomStartPosition + 1 '+1代表Title栏
BomColumnUbound = UBound(TitleArr)
BomRowCount = BomRowUbound + 1
BomColumnCount = BomColumnUbound + 1
ReDim BomArr(0 To BomRowUbound, 0 To BomColumnUbound)
For j = 0 To BomColumnUbound
BomArr(0, j) = TitleArr(j)
Next j
BomPartNumber = 0
For i = 1 To BomRowUbound
LinesArr = Split(lines(i - 1 + BomStartPosition), vbTab)
For j = 0 To UBound(LinesArr)
BomArr(i, j) = LinesArr(j)
Next j
If BomArr(i, 0) <> "" Then
BomPartNumber = BomPartNumber + 1
End If
Next i
'建立BomPartArr()数组
r = 1
BomOnePartRows = 0
ReDim BomPartArr(1 To BomPartNumber, 1 To 3)
For i = 1 To BomRowUbound
If BomArr(i, 0) <> "" Then
BomPartArr(r, 1) = BomArr(i, 3)
BomPartArr(r, 2) = i
BomOnePartRows = 0
r = r + 1
End If
BomOnePartRows = BomOnePartRows + 1
BomPartArr(r - 1, 3) = BomOnePartRows
Next i
'测试BomPartArr()数组
' Sheet5.Select
' Sheet5.Range("A1").Activate
' Sheet5.Activate
' Sheet5.UsedRange.ClearContents
' Sheet5.Cells(1, 1).Resize(BomPartNumber, 3).Value = BomPartArr
'在Sheet3中显示确实BomArr()的正确性
' Sheet3.Select
' Sheet3.Range("A1").Activate
' Sheet3.UsedRange.ClearContents
' Sheet3.Cells(BomTitleStartPosition + 1, 1).Resize(BomRowCount, BomColumnCount).Value = BomArr
'----------------------------------------读取BOM文件-----------------------------------------------------
'读取Store中的数组到数组中
' On Error Resume Next
Sheets("TMT PN").Activate
Sheets("TMT PN").Range("A1").Activate
StoreLastRow = Sheets("TMT PN").[A65536].End(xlUp).Row
StoreLastColumn = Sheets("TMT PN").[IV1].End(xlToLeft).Column
ReDim StoreArr(0 To StoreLastRow - 1, 0 To StoreLastColumn - 1)
For i = 0 To StoreLastRow - 1
For j = 0 To StoreLastColumn - 1
StoreArr(i, j) = ActiveCell.Offset(i, j)
Next j
Next i
' On Error GoTo 0
' Store = ActiveCell.Resize(StoreLastRow, StoreLastColumn)
''在Sheet4中显示确实StoreArr()的正确性
' Sheet4.Select
' Sheet4.Range("A1").Activate
' Sheet4.UsedRange.ClearContents
' Sheet4.Cells(1, 1).Resize(StoreLastRow, StoreLastColumn).Value = StoreArr
'在STORE的Value项中搜寻BOM中的Part栏
BomFoundFlag = False
BomNotFoundRows = 0
For i = 1 To BomPartNumber
For j = 1 To StoreLastRow - 1
If StoreArr(j, 0) = BomPartArr(i, 1) Then
BomFoundFlag = True
End If
Next j
If BomFoundFlag = False Then
BomNotFoundRows = BomNotFoundRows + 1
ReDim Preserve BomNotFoundArr(1 To BomNotFoundRows)
BomNotFoundArr(BomNotFoundRows) = BomPartArr(i, 1)
End If
BomFoundFlag = False
Next i
'测试BomNotFoundArr()
If BomNotFoundRows > 0 Then
Sheets("NOTFOUND").Select
Sheets("NOTFOUND").Range("A1").Activate
Sheets("NOTFOUND").UsedRange.ClearContents
Sheets("NOTFOUND").Cells(1, 1).Resize(BomNotFoundRows, 1).Value = Application.WorksheetFunction.Transpose(BomNotFoundArr)
MsgBox ("有元件不在TMT PN中,详情请查看SHEET<NOTFOUND>")
End If
'建立BOM,合并BomArr(0 To BomRowUbound, 0 To BomColumnUbound)
'和StoreArr(0 To StoreLastRow - 1, 0 To StoreLastColumn - 1)
If BomNotFoundRows = 0 Then
ReDim BomBuildArr(0 To BomRowUbound, 0 To BomColumnUbound + StoreLastColumn - 1)
'建立BOM Title
For k = 0 To BomColumnUbound + StoreLastColumn - 1
If k <= BomColumnUbound Then
BomBuildArr(0, k) = BomArr(0, k)
Else
BomBuildArr(0, k) = StoreArr(0, k - BomColumnUbound)
End If
Next k
r = 1
For j = 1 To StoreLastRow - 1
For i = 1 To BomPartNumber
If BomPartArr(i, 1) = StoreArr(j, 0) Then
'当在BomPartArr()中找到时，输出BOM到BomBuildArr()中保存
'BomPartArr第2栏中存有Bom在BomArr()中的位置
'BomPartArr第3栏中村有OneBom的行数
For k = 0 To BomColumnUbound + StoreLastColumn - 1
If k <= BomColumnUbound Then
BomBuildArr(r, k) = BomArr(BomPartArr(i, 2), k)
Else
BomBuildArr(r, k) = StoreArr(j, k - BomColumnUbound)
End If
Next k
r = r + 1
If BomPartArr(i, 3) > 1 Then
For m = 1 To BomPartArr(i, 3) - 1
For n = 0 To BomColumnUbound
BomBuildArr(r, n) = BomArr(BomPartArr(i, 2) + m, n)
Next n
r = r + 1
Next m
End If
End If
Next i
Next j
'在Excel中显示BOM
Sheets("BOM").Select
Sheets("BOM").Range("A1").Activate
Sheets("BOM").Cells(14, 1).Resize(BomRowUbound + 1, BomColumnUbound + StoreLastColumn).Value = BomBuildArr
End If
ActiveSheet.Copy
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.Zoom = 100
Dim MaxRows As Integer
MaxRows = ActiveSheet.UsedRange.Rows.Count
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$H$" & MaxRows
' .PaperSize = xlPaperA4
.Orientation = xlLandscape
End With
ActiveWorkbook.Close SaveChanges:=True, FileName:=ThisWorkbook.Path & "/" & FileNameOnly & "_BOM_" & Format(Date, "yyyymmdd") & ".xlsx"
Application.ScreenUpdating = True
End Sub
下面是网上搜索的几个过程
Function GetFileLinesCount(ByVal InputFileName As String)
Dim arr
Open InputFileName For Input As #1
If Err <> 0 Then
MsgBox "Not found: " & Filename, vbCritical, "Error"
Exit Function
End If
arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
GetFileLinesCount = UBound(arr) + 1
Reset
End Function
Sub addall()
Application.ScreenUpdating = False '防止屏幕抖动，屏幕刷新禁止
Dim arr() As String, i As Long, j As Long, n As Long, temp As String, lines() As String, x As Long
ReDim arr(1 To 10, 1 To 65535)
temp = Dir([a1] & "/*.txt")
While temp > "" '循环语句，当temp枚举完毕后退出循环
n = n + 1
ReDim Preserve arr(1 To 10, 1 To n) '重新分配数组大小
arr(1, n) = temp '数组(1,n)为文件名
On Error Resume Next '遇到错误,直接退出
Open [a1] & "/" & temp For Input As #1 '使用1#通道存储打开的文件
lines = Split(StrConv(InputB(LOF(1), #1), vbUnicode), vbCrLf) '将1号通道打开的文件,写入到lines数组中,
'lines = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) #1写成1也是可以的
'变量 = Input（串长度，文件号）
'inputb:如果要将整个文件复制到变量，请使用InputB函数将字节从文件复制到变量。
'由于InputB函数返回一个ASCII字符串，因此，必须用StrCopy函数将ASCII字符串转换为Unicode字符串。
'代码如下：file = StrCopy （Input （LOF（filenanum），filenum），vbUnicode）
'vbCrLf ,遇上回车换行符为止
Close #1 '关闭1#通道
For j = 2 To 10
arr(j, n) = Replace(Split(lines(Cells(1, j) - 1))(0), ",", "")
'arr(j, n) = Split(lines(Cells(1, j) - 1))(0)
'Cells(1, j)假设为5
'lines(Cells(1, j)-1) lines的第5个元素(下标从0开始)
'Split(lines(Cells(1, j) - 1)) 以空格分割
'Split(lines(Cells(1, j) - 1))(0) 第1个元素
'Replace(Split(lines(Cells(1, j) - 1))(1),",","") 第2个元素去掉逗号
Next
temp = Dir()
Wend
[a2].Resize(n, 10) = WorksheetFunction.Transpose(arr) '转置粘贴
Application.ScreenUpdating = True '允许屏幕刷新
End Sub
这个是正则表达式的列子
Function GetColumn(strT As String, icol As Integer) As String
Dim regEx As RegExp
Dim Matches As MatchCollection
Set regEx = New RegExp
regEx.Pattern = "[^ ]+"
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(strT)
If icol > (Matches.Count + 1) Then
MsgBox "The column number is oversize, please check", vbCritical
GetColumn = "Error!"
Else
GetColumn = Matches.Item(icol - 1)
End If
End Function
Sub mmm1()
Dim strT As String
Dim bStart As Boolean
Dim i As Integer
bStart = False
Open "c:/xfwen/excelhelp/20061120/ctc_0618668101_cx.txt" For Input As #1
i = 1
Do While Not EOF(1)
Line Input #1, strT
If InStr(1, strT, "Measured And Repredicted Sample Data") > 0 Then 'end of Basic Sample data
bStart = False
Exit Do
End If
If bStart = True Then
Cells(i, 1) = GetColumn(strT, 8) 'get data of the 8th column(include the "|"), start from 1
i = i + 1
End If
If InStr(1, strT, "Basic Sample Data") > 0 Then 'start of Basic sample data
Line Input #1, strT 'first line of title
Line Input #1, strT 'second line of title
Line Input #1, strT 'third line of title
bStart = True 'now you can start
End If
Loop
Close #1
End Sub
扫一扫
636
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
