20170612xlVBA多文件多类别分类求和匹配

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

　　

转载于:https://www.cnblogs.com/nextseven/p/7129109.html