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