Sub BOM生成()
Dim t1, t2 As String

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
k = 1
'If ActiveWorkbook.Worksheets.Count = 1 Then
'    MsgBox "尚未匯入資料庫，請匯入資料庫後再執行"
'    Exit Sub
'End If

On Error GoTo special

ChDrive "C:"
ChDir "C:\My Documents"

選取檔案

If ActiveWorkbook.Worksheets.Count = 1 Then
    MsgBox ("未匯入資料，請重新匯入")
    GoTo fini
End If

If Worksheets(2).Cells(2, 2) <> "0" Then
    MsgBox ("匯入資料格式異常")
    Worksheets(2).Delete
    GoTo fini
End If

If k = 0 Then
    MsgBox "請將多餘的資料庫刪除"
    GoTo fini
End If

工作頁面清潔
Worksheets(2).Activate
資料表頭整理
半成品件判斷
ws2_data_end_num = Cells(65536, "B").End(xlUp).Row
ws2_mark_end_num = Cells(1, 256).End(xlToLeft).Column
ws2_data_num = ws2_data_end_num - 2
ws1_num = 1

序號欄位 = 目標欄位檢索(1, "序號", ws2_mark_end_num)
元件品號欄位 = 目標欄位檢索(1, "元件品號", ws2_mark_end_num)
屬性欄位 = 目標欄位檢索(1, "屬性", ws2_mark_end_num)
品名欄位 = 目標欄位檢索(1, "品名", ws2_mark_end_num)
規格欄位 = 目標欄位檢索(1, "規格", ws2_mark_end_num)
插件位置欄位 = 目標欄位檢索(1, "插件位置1", ws2_mark_end_num)
組成用量欄位 = 目標欄位檢索(1, "組成用量", ws2_mark_end_num)
底數欄位 = 目標欄位檢索(1, "底數", ws2_mark_end_num)
單位欄位 = 目標欄位檢索(1, "單位", ws2_mark_end_num)
標準批量欄位 = 目標欄位檢索(1, "標準批量", ws2_mark_end_num)
階次欄位 = 目標欄位檢索(1, "階次", ws2_mark_end_num)
損耗率欄位 = 目標欄位檢索(1, "損耗率%", ws2_mark_end_num)
類型欄位 = 目標欄位檢索(1, "類型", ws2_mark_end_num)



For ws2_count_num = 2 To ws2_data_num Step 1

    If Worksheets(2).Cells(ws2_count_num, 階次欄位) <> "" And Worksheets(2).Cells(ws2_count_num, 標準批量欄位) = 1 Then
       Worksheets(1).Cells(ws1_num, "B") = Worksheets(2).Cells(ws2_count_num, 元件品號欄位)
       Worksheets(1).Cells(ws1_num, "C") = Worksheets(2).Cells(ws2_count_num, 品名欄位)
       Worksheets(1).Cells(ws1_num, "B").Interior.ColorIndex = 6
       Worksheets(1).Cells(ws1_num, "C").HorizontalAlignment = xlLeft
       Worksheets(1).Cells(ws1_num, "C").Interior.ColorIndex = 6
       
       mark_ini_num = ws1_num
       
       ws1_num = ws1_num + 1
       
       Worksheets(1).Cells(ws1_num, "A") = "序號"
       Worksheets(1).Cells(ws1_num, "B") = "元件品號"
       Worksheets(1).Cells(ws1_num, "C") = "品名"
       Worksheets(1).Cells(ws1_num, "D") = "規格"
       Worksheets(1).Cells(ws1_num, "E") = "組成用量"
       Worksheets(1).Cells(ws1_num, "F") = "底數"
       Worksheets(1).Cells(ws1_num, "G") = "單位"
       Worksheets(1).Cells(ws1_num, "H") = "損耗率%"
       Worksheets(1).Cells(ws1_num, "I") = "插件位置"
       Worksheets(1).Cells(ws1_num, "J") = "屬性"
       Worksheets(1).Cells(ws1_num, "K") = "貨號"
       
       
       
       ws1_num = ws1_num + 1
       ws2_loop_num = 1 + ws2_count_num
       
'==============================================================================================
       
        Do While Worksheets(2).Cells(ws2_count_num, 階次欄位) <> ""
            t1 = Val(Right(Worksheets(2).Cells(ws2_count_num, "B"), 1))
            t2 = Val(Right(Worksheets(2).Cells(ws2_loop_num, "B"), 1))
            
            If t2 - t1 = 0 Then
                Exit Do
                
            ElseIf t2 - t1 = 1 Then
                
                Worksheets(1).Cells(ws1_num, "A") = Worksheets(2).Cells(ws2_loop_num, 序號欄位)
                Worksheets(1).Cells(ws1_num, "A").HorizontalAlignment = xlCenter
                Worksheets(1).Cells(ws1_num, "B") = Worksheets(2).Cells(ws2_loop_num, 元件品號欄位)
                Worksheets(1).Cells(ws1_num, "B").HorizontalAlignment = xlCenter
                Worksheets(1).Cells(ws1_num, "C") = Worksheets(2).Cells(ws2_loop_num, 品名欄位)
                Worksheets(1).Cells(ws1_num, "C").HorizontalAlignment = xlLeft
                Worksheets(1).Cells(ws1_num, "D") = Worksheets(2).Cells(ws2_loop_num, 規格欄位)
                Worksheets(1).Cells(ws1_num, "D").HorizontalAlignment = xlLeft
                Worksheets(1).Cells(ws1_num, "E") = Worksheets(2).Cells(ws2_loop_num, 組成用量欄位)
                Worksheets(1).Cells(ws1_num, "E").HorizontalAlignment = xlCenter
                Worksheets(1).Cells(ws1_num, "F") = Worksheets(2).Cells(ws2_loop_num, 底數欄位)
                Worksheets(1).Cells(ws1_num, "F").HorizontalAlignment = xlCenter
                Worksheets(1).Cells(ws1_num, "G") = Worksheets(2).Cells(ws2_loop_num, 單位欄位)
                Worksheets(1).Cells(ws1_num, "G").HorizontalAlignment = xlCenter
                Worksheets(1).Cells(ws1_num, "H") = Worksheets(2).Cells(ws2_loop_num, 損耗率欄位)
                Worksheets(1).Cells(ws1_num, "H").HorizontalAlignment = xlCenter
                Worksheets(1).Cells(ws1_num, "I") = Worksheets(2).Cells(ws2_loop_num, 插件位置欄位)
                Worksheets(1).Cells(ws1_num, "I").HorizontalAlignment = xlCenter
                Worksheets(1).Cells(ws1_num, "J") = Worksheets(2).Cells(ws2_loop_num, 屬性欄位)
                Worksheets(1).Cells(ws1_num, "J").HorizontalAlignment = xlCenter
                Worksheets(1).Cells(ws1_num, "K") = Worksheets(2).Cells(ws2_loop_num, 類型欄位)
                Worksheets(1).Cells(ws1_num, "K").HorizontalAlignment = xlCenter
                
                If Worksheets(2).Cells(ws2_loop_num, 標準批量欄位) = 1 Then
                    Worksheets(1).Activate
                    Worksheets(1).Range(Cells(ws1_num, "A"), Cells(ws1_num, "K")).Font.ColorIndex = 7
                End If
                
                ws1_num = ws1_num + 1
                          
                
            End If
                        
            ws2_loop_num = ws2_loop_num + 1
            
            If ws2_loop_num > ws2_data_end_num Then Exit Do
                    
        Loop
        
''==============================================================================================
        mark_end_num = ws1_num - 1
        Worksheets(1).Activate
        Worksheets(1).Range(Cells(mark_ini_num + 1, 1), Cells(mark_end_num, "K")).Borders.LineStyle = xlContinuous
''==============================================================================================
        Worksheets(1).Range(Cells(mark_ini_num + 1, 1), Cells(mark_end_num, "K")).BorderAround Weight:=xlMedium
'==============================================================================================
        Worksheets(1).Range(Cells(mark_ini_num, 2), Cells(mark_ini_num, 3)).BorderAround Weight:=xlMedium
'==============================================================================================
        
        
        ws1_num = ws1_num + 1
   
    End If

Next

Columns("A:K").AutoFit
Columns("A:P").Select
ActiveWindow.Zoom = True
Cells(1, 1).Select


GoTo fini

special:

MsgBox "發生錯誤，請與相關人員聯繫。"

fini:

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True

End Sub
Sub 資料表頭整理()

Dim coun_num1, coun_num2, 主件品號欄位, 元件品號欄位, 資料表頭尾端, 資料表串尾端 As Integer

'Worksheets(2).Activate

資料表頭尾端 = Cells(1, 256).End(xlToLeft).Column

資料表串尾端 = Cells(65536, "E").End(xlUp).Row

For coun_num2 = 1 To 資料表串尾端 Step 1

    Cells(1, coun_num2) = Replace(Cells(1, coun_num2), " ", "")
Next

'==============================================================================

主件品號欄位 = 目標欄位檢索(1, "主件品號", 資料表頭尾端)

元件品號欄位 = 目標欄位檢索(1, "元件品號", 資料表頭尾端)

'==============================================================================

For coun_num1 = 1 To 資料表串尾端 Step 1

    If Cells(coun_num1, 元件品號欄位) = "" Then
        Cells(coun_num1, 元件品號欄位) = Cells(coun_num1, 主件品號欄位)
    End If
Next
       

For coun_num2 = 1 To 資料表串尾端 Step 1

    Cells(1, coun_num2) = Replace(Cells(1, coun_num2), " ", "")
Next


End Sub
Sub 工作頁面清潔()
Worksheets(1).Activate
Columns("A:K").Clear
Columns("A:K").HorizontalAlignment = xlCenter
Columns("A:K").ClearContents

End Sub
Sub 資料清潔()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets(1).Activate
Columns("A:K").Clear
Columns("A:K").HorizontalAlignment = xlCenter
Columns("A:K").ClearContents
Columns("A:K").ColumnWidth = 8

On Error GoTo spcecial

If Worksheets(1).Name <> "BOM生成區" Then

Worksheets("BOM生成區").Move before:=Worksheets(1)

End If

Do While Worksheets.Count <> 1

Worksheets(2).Delete

Loop

GoTo finish

spcecial:

MsgBox ("工作表異常，請聯絡維護人員")

finish:


Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
Function 目標欄位檢索(ByVal 檢索列 As Integer, ByVal 檢索目標 As String, ByVal 資料尾端 As Integer)
Dim coun_num As Integer

For coun_num = 1 To 資料尾端
    If Cells(檢索列, coun_num) = 檢索目標 Then
        
        Exit For
    End If
    目標欄位檢索 = 256
Next

目標欄位檢索 = coun_num

End Function
Sub 選取檔案()

Dim 開啟檔案路徑 As Variant

k = 1

If ActiveWorkbook.Worksheets.Count > 1 Then
    k = 0
    Exit Sub
End If

開啟檔案路徑 = Application.GetOpenFilename(",*.xls")

If 開啟檔案路徑 = False Then Exit Sub

目標工作簿名稱 = ActiveWorkbook.Name

Workbooks.Open (開啟檔案路徑)

開啟工作簿名稱 = ActiveWorkbook.Name

Workbooks(開啟工作簿名稱).Sheets(1).Copy after:=Workbooks(目標工作簿名稱).Sheets("BOM生成區")

Workbooks(開啟工作簿名稱).Close

Workbooks(目標工作簿名稱).Sheets(2).Select

失效清除

Workbooks(目標工作簿名稱).Sheets("BOM生成區").Select

'Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
'Application.DisplayStatusBar = True
'Application.EnableEvents = True

End Sub

Sub 半成品件判斷()

Worksheets(2).Activate
ws2_data_end_num = Cells(65536, "B").End(xlUp).Row
ws2_mark_end_num = Cells(1, 256).End(xlToLeft).Column
標準批量欄位 = 目標欄位檢索(1, "標準批量", ws2_mark_end_num)
屬性欄位 = 目標欄位檢索(1, "屬性", ws2_mark_end_num)


For coun_num1 = 2 To ws2_data_end_num
    If Cells(coun_num1, 屬性欄位) = "託外加工件" Or Cells(coun_num1, 屬性欄位) = "虛設品號" Or Cells(coun_num1, 屬性欄位) = "自製件" Then
        Cells(coun_num1, 標準批量欄位) = 1
        
    Else
        Cells(coun_num1, 標準批量欄位) = 0
    
    End If
Next

End Sub
Sub 失效清除()

Dim aRng As Range

f = Cells(Rows.Count, 1).End(xlUp).Row

g = Cells(1, Columns.Count).End(xlToLeft).Column

Set aRng = Cells.Find(what:="失效日期", LookAt:=xlWhole)
Set bRng = Cells.Find(what:="階  次", LookAt:=xlWhole)

If aRng Is Nothing Then Exit Sub
If bRng Is Nothing Then Exit Sub

k1 = aRng.Column
k2 = aRng.Row

j1 = bRng.Column
j2 = bRng.Row


For s1 = 1 To f Step 1

    
    If Cells(s1, k1) <> "" And Cells(s1, k1) <> "失效日期" Then
    
        u1 = Right(Cells(s1, j1), 1)
        
        Do
       
            Cells(s1, 31) = "V"
        
            s1 = s1 + 1
            
            If s1 = f + 1 Then Exit Sub
        
        Loop Until Right(Cells(s1, j1), 1) = u1
        
        If Cells(s1, k1) <> "" Then
        
            s1 = s1 - 1
        
        End If
        

    End If

Next


For s2 = f To 1 Step -1

    If Cells(s2, 31) = "V" Then

    Rows(s2).Delete

    End If

Next

End Sub


我的VBA目前只能讀取一個EXCEL檔，我想要修改成可以讀取多個檔案