Public Sub Basic_CodeFrame()
    AppSettings
    ‘On Error GoTo ErrHandler
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    ‘Input code here

    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Dim NewWb As Workbook
    Dim NewSht As Worksheet
    Dim Arr As Variant
    Dim i As Long, j As Long
    Dim EndRow As Long
    Dim Brr()
    Dim Crr()
    Dim Drr()
    Dim Index As Long
    Dim Index1 As Long
    Dim Index2 As Long
    Dim OneKey As Variant
   
    Dim Title As Variant
   
    Dim FolderPath As String
    Const FolderName As String = "原始文件"
    Const OutPutName As String = "結果文件"

    Const OpFile1 As String = "臺面補貨d.xlsx"
    Const OpFile2 As String = "品牌補貨d.xlsx"
    Const OpFile3 As String = "小類補貨d.xlsx"

    Dim OpPath As String


    Const AName As String = "盤點"
    Dim aFile As String, aPath As String
    Const CName As String = "產品資料"
    Dim cFile As String, cPath As String
    Const BName As String = "庫存"
    Dim bFile As String, bPath As String
    Const DName As String = "銷售"
    Dim dFile As String, dPath As String



    Dim aInfo(1 To 4) As Object
    Dim bInfo(1 To 4) As Object
    Dim cInfo(1 To 18) As Object
    Dim dInfo(1 To 5) As Object
    Dim dCate As Object    ‘小類
    Dim dBrand As Object    ‘品牌
    Dim Cate As String
    Dim Brand As String
    Set dCate = CreateObject("Scripting.Dictionary")
    Set dBrand = CreateObject("Scripting.Dictionary")

    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("標題")
    Title = Sht.Range("A1:X1").Value
    FolderPath = Wb.Path & Application.PathSeparator & _
                 FolderName & Application.PathSeparator


    ‘先到C表保存各種字段信息

    For j = 1 To 18
        Set cInfo(j) = CreateObject("Scripting.Dictionary")
    Next j

    cFile = Dir(FolderPath & "*" & CName & "*.xls*")
    cPath = FolderPath & cFile
    Debug.Print cPath

    Set OpenWb = Application.Workbooks.Open(cPath)
    Set OpenSht = OpenWb.Worksheets(1)
    With OpenSht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A2:R" & EndRow)
        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
            Key = CStr(Arr(i, 1))
            Key = Replace(Key, " ", "")
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                cInfo(j)(Key) = Arr(i, j)
            Next j
        Next i
    End With
    Set OpenSht = Nothing
    OpenWb.Close False

    ‘再到A表讀取報貨單
    For j = 1 To 4
        Set aInfo(j) = CreateObject("Scripting.Dictionary")
    Next j

    aFile = Dir(FolderPath & "*" & AName & "*.xls*")
    aPath = FolderPath & aFile
    Debug.Print aPath

    Set OpenWb = Application.Workbooks.Open(aPath)
    Set OpenSht = OpenWb.Worksheets(1)

    With OpenSht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A2:D" & EndRow)
        Arr = Rng.Value

        For i = LBound(Arr) To UBound(Arr)
            Key = CStr(Arr(i, 1))
            Key = Replace(Key, " ", "")
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                aInfo(j)(Key) = Arr(i, j)
            Next j
        Next i

    End With
    Set OpenSht = Nothing
    OpenWb.Close False


    ‘再到B表讀取庫存
    For j = 1 To 4
        Set bInfo(j) = CreateObject("Scripting.Dictionary")
    Next j

    bFile = Dir(FolderPath & "*" & BName & "*.xls*")
    bPath = FolderPath & bFile
    Debug.Print bPath

    Set OpenWb = Application.Workbooks.Open(bPath)
    Set OpenSht = OpenWb.Worksheets(1)

    With OpenSht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A2:D" & EndRow)
        Arr = Rng.Value

        For i = LBound(Arr) To UBound(Arr)
            Key = CStr(Arr(i, 1))
            Key = Replace(Key, " ", "")
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                bInfo(j)(Key) = Arr(i, j)
            Next j
        Next i

    End With
    Set OpenSht = Nothing
    OpenWb.Close False



    ‘再到D表讀取銷售
    For j = 1 To 5
        Set dInfo(j) = CreateObject("Scripting.Dictionary")
    Next j

    dFile = Dir(FolderPath & "*" & DName & "*.xls*")
    dPath = FolderPath & dFile
    Debug.Print dPath

    Set OpenWb = Application.Workbooks.Open(dPath)
    Set OpenSht = OpenWb.Worksheets(1)

    With OpenSht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A2:D" & EndRow)
        Arr = Rng.Value

        For i = LBound(Arr) To UBound(Arr)
            Key = CStr(Arr(i, 1))
            Key = Replace(Key, " ", "")
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                dInfo(j)(Key) = Arr(i, j)
            Next j
        Next i

    End With
    Set OpenSht = Nothing
    OpenWb.Close False


    ‘保存上報品牌與小類
    ‘For Each OneKey In aInfo(1).keys
    ‘Brand = cInfo(6)(OneKey) ‘保存品牌
    ‘dBrand(Brand) = ""
    ‘Cate = cInfo(4)(OneKey) ‘保存小類
    ‘dCate(Cate) = ""
    ‘Next OneKey

    ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>


    ‘計算臺面補貨
    ReDim Brr(1 To 24, 1 To 1)
    Index = 0
    For Each OneKey In aInfo(1).keys
        Index = Index + 1
        ReDim Preserve Brr(1 To 24, 1 To Index)
        Brr(1, Index) = OneKey & "     "    ‘條碼
        Brr(2, Index) = cInfo(2)(OneKey)    ‘商品名稱2
        Brr(3, Index) = IIf(aInfo(4)(OneKey) = "", 0, aInfo(4)(OneKey))    ‘商場庫存4
        Brr(4, Index) = IIf(bInfo(3)(OneKey) = "", 0, bInfo(3)(OneKey))    ‘總部庫存3
        Brr(5, Index) = IIf(dInfo(3)(OneKey) = "", 0, dInfo(3)(OneKey))    ‘銷售數量3
        Brr(6, Index) = cInfo(6)(OneKey)   ‘品牌6
        Brr(7, Index) = cInfo(4)(OneKey)    ‘小類4

        Brand = cInfo(6)(OneKey)    ‘保存品牌
        dBrand(Brand) = ""
        Cate = cInfo(4)(OneKey)    ‘保存小類
        dCate(Cate) = ""

        Brr(8, Index) = (Brr(5, Index) - Brr(3, Index)) * 1.5   ‘(D-A)*1.5 要出多少貨
        If Brr(8, Index) > 0 Then
            If Brr(4, Index) >= Brr(8, Index) Then    ‘庫存足夠出貨
                Brr(9, Index) = Brr(8, Index)    ‘直接出貨
                Brr(10, Index) = ""    ‘無需采購
            Else
                Brr(9, Index) = Brr(4, Index)    ‘庫存全出
                Brr(10, Index) = Brr(8, Index) - Brr(4, Index)    ‘計算采購
            End If
        End If
        ‘------
        Brr(11, Index) = cInfo(3)(OneKey)    ‘大類
        Brr(12, Index) = cInfo(5)(OneKey)    ‘規格
        For j = 1 To 12
            Brr(j + 12, Index) = cInfo(j + 6)(OneKey)
        Next j
    Next OneKey

    ‘創建臺面補貨文件
    OpPath = Wb.Path & "\" & OutPutName & "\" & Replace(OpFile1, "d", "-" & Split(dFile, ".")(0))
    Debug.Print OpPath

    Set NewWb = Application.Workbooks.Add()
    Set NewSht = NewWb.Worksheets(1)
    NewSht.Name = Split(OpFile1, "d")(0)
    NewWb.SaveAs OpPath
    With NewSht
        .Columns("A:A").NumberFormat = "@"
        .Range("A1:X1").Value = Title
        .Range("a2").Resize(Index, 24).Value = _
        Application.WorksheetFunction.Transpose(Brr)
    End With

    NewWb.Close True
    ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    ‘計算品牌與小類補貨
    ReDim Crr(1 To 24, 1 To 1)
    ReDim Drr(1 To 24, 1 To 1)

    Index1 = 0
    Index2 = 0
    For Each OneKey In cInfo(1).keys

        Brand = cInfo(6)(OneKey)    ‘保存品牌
        If dBrand.Exists(Brand) Then    ‘屬於改品牌
            Index1 = Index1 + 1
            ReDim Preserve Crr(1 To 24, 1 To Index1)
            Crr(1, Index1) = OneKey & "     "    ‘條碼
            Crr(2, Index1) = cInfo(2)(OneKey)    ‘商品名稱2
            Crr(3, Index1) = IIf(aInfo(4)(OneKey) = "", 0, aInfo(4)(OneKey))    ‘商場庫存4
            Crr(4, Index1) = IIf(bInfo(3)(OneKey) = "", 0, bInfo(3)(OneKey))    ‘總部庫存3
            Crr(5, Index1) = IIf(dInfo(3)(OneKey) = "", 0, dInfo(3)(OneKey))    ‘銷售數量3
            Crr(6, Index1) = cInfo(6)(OneKey)   ‘品牌6
            Crr(7, Index1) = cInfo(4)(OneKey)    ‘小類4
            Crr(8, Index1) = (Crr(5, Index1) - Crr(3, Index1)) * 1.5   ‘(D-A)*1.5 要出多少貨
            If Crr(8, Index1) > 0 Then
                If Crr(4, Index1) >= Crr(8, Index1) Then    ‘庫存足夠出貨
                    Crr(9, Index1) = Crr(8, Index1)    ‘直接出貨
                    Crr(10, Index1) = ""    ‘無需采購
                Else
                    Crr(9, Index1) = Crr(4, Index1)    ‘庫存全出
                    Crr(10, Index1) = Crr(8, Index1) - Crr(4, Index1)    ‘計算采購
                End If
            End If
            ‘------
            Crr(11, Index1) = cInfo(3)(OneKey)    ‘大類
            Crr(12, Index1) = cInfo(5)(OneKey)    ‘規格
            For j = 1 To 12
                Crr(j + 12, Index1) = cInfo(j + 6)(OneKey)
            Next j
        End If
        Cate = cInfo(4)(OneKey)    ‘保存小類
        If dCate.Exists(Cate) Then
            Index2 = Index2 + 1
            ReDim Preserve Drr(1 To 24, 1 To Index2)
            Drr(1, Index2) = OneKey & "     "    ‘條碼
            Drr(2, Index2) = cInfo(2)(OneKey)    ‘商品名稱2
            Drr(3, Index2) = IIf(aInfo(4)(OneKey) = "", 0, aInfo(4)(OneKey))    ‘商場庫存4
            Drr(4, Index2) = IIf(bInfo(3)(OneKey) = "", 0, bInfo(3)(OneKey))    ‘總部庫存3
            Drr(5, Index2) = IIf(dInfo(3)(OneKey) = "", 0, dInfo(3)(OneKey))    ‘銷售數量3
            Drr(6, Index2) = cInfo(6)(OneKey)   ‘品牌6
            Drr(7, Index2) = cInfo(4)(OneKey)    ‘小類4
            Drr(8, Index2) = (Drr(5, Index2) - Drr(3, Index2)) * 1.5   ‘(D-A)*1.5 要出多少貨
            If Drr(8, Index2) > 0 Then
                If Drr(4, Index2) >= Drr(8, Index2) Then    ‘庫存足夠出貨
                    Drr(9, Index2) = Drr(8, Index2)    ‘直接出貨
                    Drr(10, Index2) = ""    ‘無需采購
                Else
                    Drr(9, Index2) = Drr(4, Index2)    ‘庫存全出
                    Drr(10, Index2) = Drr(8, Index2) - Drr(4, Index2)    ‘計算采購
                End If
            End If
            ‘------
            Drr(11, Index2) = cInfo(3)(OneKey)    ‘大類
            Drr(12, Index2) = cInfo(5)(OneKey)    ‘規格
            For j = 1 To 12
                Drr(j + 12, Index2) = cInfo(j + 6)(OneKey)
            Next j
        End If

    Next OneKey

    ‘創建品牌補貨文件
    OpPath = Wb.Path & "\" & OutPutName & "\" & Replace(OpFile2, "d", "-" & Split(dFile, ".")(0))
    Debug.Print OpPath

    Set NewWb = Application.Workbooks.Add()
    Set NewSht = NewWb.Worksheets(1)
    NewSht.Name = Split(OpFile2, "d")(0)
    NewWb.SaveAs OpPath
    With NewSht
        .Columns("A:A").NumberFormat = "@"
        .Range("A1:X1").Value = Title
        .Range("a2").Resize(Index, 24).Value = _
        Application.WorksheetFunction.Transpose(Crr)
    End With

    NewWb.Close True

    ‘創建小類補貨文件
    OpPath = Wb.Path & "\" & OutPutName & "\" & Replace(OpFile3, "d", "-" & Split(dFile, ".")(0))
    Debug.Print OpPath

    Set NewWb = Application.Workbooks.Add()
    Set NewSht = NewWb.Worksheets(1)
    NewSht.Name = Split(OpFile3, "d")(0)
    NewWb.SaveAs OpPath
    With NewSht
        .Columns("A:A").NumberFormat = "@"
        .Range("A1:X1").Value = Title
        .Range("a2").Resize(Index, 24).Value = _
        Application.WorksheetFunction.Transpose(Drr)
    End With

    NewWb.Close True


    UsedTime = VBA.Timer - StartTime
    ‘Debug.Print "UsedTime：" & Format(UsedTime, "0.000 Seconds")
    MsgBox "UsedTime：" & Format(UsedTime, "0.000 Seconds"), vbOKOnly, "NS  QQ "
ErrorExit:
    AppSettings False
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "NS QQ "
        Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub
Public Sub AppSettings(Optional IsStart As Boolean = True)
    If IsStart Then
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.Calculation = xlCalculationManual
        Application.StatusBar = ">>>>>>>>Macro Is Running>>>>>>>>"
    Else
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.Calculation = xlCalculationAutomatic
        Application.StatusBar = False
    End If
End Sub

20170612xlVBA多文件多類別分類求和匹配