一个根据.BOM文件自动创建Excel BOM的程序---记录在此,以便查询

 

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