20170622xlVBA多部门分类汇总同类合并单元格

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

    Call SubTotalData

    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, "NextSeven 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



Private Sub SubTotalData()
    Dim dShtName As Object
    Dim dInfo As Object
    Dim Key As String
    Dim OneKey
    Const MAIN_SHEET As String = "分类汇总表"
    Const SALE_SHEET As String = "销售数据汇总表"
    Const PROC_SHEET As String = "生产入库明细表"
    Const STORE_SHEET As String = "汇总后库存明细表"
    Const HEAD_ROW As Long = 3
    Const END_COL As String = "Z"
    Dim EndRow As Long
    Dim Wb As Workbook

    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim Rng As Range
    Dim Arr As Variant
    Dim Data() As Variant

    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(MAIN_SHEET)

    Set dShtName = CreateObject("Scripting.Dictionary")
    Set dInfo = CreateObject("Scripting.Dictionary")

    Key = MAIN_SHEET
    dShtName(Key) = ""

    Key = SALE_SHEET
    dShtName(Key) = ""

    Key = PROC_SHEET
    dShtName(Key) = ""

    Key = STORE_SHEET
    dShtName(Key) = ""

    For Each oSht In Wb.Worksheets
        If dShtName.EXISTS(oSht.Name) = False Then
            With oSht
                EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
                Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
                Arr = Rng.Value
                For i = LBound(Arr) To UBound(Arr)
                    Key = CStr(Arr(i, 3))
                    Item = CStr(Arr(i, 3)) & ";" & CStr(Arr(i, 4)) & _
                           ";" & CStr(Arr(i, 5)) & ";" & CStr(Arr(i, 6))
                    'Debug.Print Item
                    dInfo(Key) = Item
                Next i
            End With
        End If
    Next oSht

    ReDim Data(1 To 14, 1 To 1)
    Dim Index As Long
    Dim PlanIndex As Long
    Dim SaleIndex As Long
    Dim ProcIndex As Long
    Dim StoreIndex As Long


    Index = 0
    PlanIndex = Index
    SaleIndex = Index
    ProcIndex = Index
    StoreIndex = Index

    For Each OneKey In dInfo.keys
        Key = OneKey
        '循环所有部门工作表
        For Each oSht In Wb.Worksheets
            If dShtName.EXISTS(oSht.Name) = False Then
                With oSht
                    EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
                    Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
                    Arr = Rng.Value
                    For i = LBound(Arr) To UBound(Arr)
                        If CStr(Arr(i, 3)) = Key Then
                            PlanIndex = PlanIndex + 1    '计划生产部分

                            ReDim Preserve Data(1 To 14, 1 To PlanIndex)
                            info = Split(dInfo(Key), ";")
                            For n = LBound(info) To UBound(info)
                                Data(n + 1, PlanIndex) = info(n)
                            Next n
                            Data(5, PlanIndex) = Format(Arr(i, 1), "yyyy/mm/dd")    '日期
                            Data(6, PlanIndex) = Arr(i, 8)
                            Data(7, PlanIndex) = Arr(i, 2)
                        End If
                    Next i
                End With
            End If
        Next oSht


        Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex)    '保存最大行号
        Set oSht = Wb.Worksheets(PROC_SHEET)
        With oSht
            EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
            Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
            Arr = Rng.Value
            For i = LBound(Arr) To UBound(Arr)
                If CStr(Arr(i, 15)) = Key Then
                    ProcIndex = ProcIndex + 1  '计划生产部分
                    '重定义数组
                    If ProcIndex > Index Then ReDim Preserve Data(1 To 14, 1 To ProcIndex)

                    info = Split(dInfo(Key), ";")
                    For n = LBound(info) To UBound(info)
                        Data(n + 1, ProcIndex) = info(n)
                    Next n

                    Data(8, ProcIndex) = Format(Arr(i, 4), "yyyy/mm/dd")    '日期
                    Data(9, ProcIndex) = Arr(i, 19)
                    Data(10, ProcIndex) = Arr(i, 13)
                End If
            Next i
        End With

        Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex)    '保存最大行号
        Set oSht = Wb.Worksheets(SALE_SHEET)
        With oSht
            EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
            Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
            Arr = Rng.Value
            For i = LBound(Arr) To UBound(Arr)
                If CStr(Arr(i, 17)) = Key Then
                    SaleIndex = SaleIndex + 1  '计划生产部分
                    '重定义数组
                    If SaleIndex > Index Then ReDim Preserve Data(1 To 14, 1 To SaleIndex)
                    info = Split(dInfo(Key), ";")
                    For n = LBound(info) To UBound(info)
                        Data(n + 1, SaleIndex) = info(n)
                    Next n
                    Data(11, SaleIndex) = Arr(i, 6)
                    Data(12, SaleIndex) = Arr(i, 21)

                End If
            Next i
        End With



        Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex)    '保存最大行号
        Set oSht = Wb.Worksheets(STORE_SHEET)
        With oSht
            EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
            Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL))
            Arr = Rng.Value
            For i = LBound(Arr) To UBound(Arr)
                If CStr(Arr(i, 2)) = Key Then
                    StoreIndex = StoreIndex + 1  '计划生产部分
                    '重定义数组
                    If StoreIndex > Index Then ReDim Preserve Data(1 To 14, 1 To StoreIndex)
                    info = Split(dInfo(Key), ";")
                    For n = LBound(info) To UBound(info)
                        Data(n + 1, StoreIndex) = info(n)
                    Next n

                    Data(13, StoreIndex) = Arr(i, 6)
                    Data(14, StoreIndex) = Format(Arr(i, 4), "yyyy/mm/dd")

                End If
            Next i
        End With

        '再次初始化
        Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex)    '保存最大行号
        PlanIndex = Index
        SaleIndex = Index
        ProcIndex = Index
        StoreIndex = Index

    Next OneKey


    Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex)

    With Sht
        .UsedRange.Offset(2).Clear
        Set Rng = .Range("A3").Resize(Index, 14)
        Rng.Value = Application.WorksheetFunction.Transpose(Data) '输出数组
        MergeSameItem .UsedRange '合并同项
        SetEdges .UsedRange '设置居中与边框
    End With

End Sub
Private Sub MergeSameItem(ByVal RngWithTitle As Range)
'禁止合并单元格过程中出现警告提示
    Application.DisplayAlerts = False
    Dim i As Integer
    Dim RowCount As Long
    Dim LastRow As Long
    Dim FirstRow As Long
    With RngWithTitle
        '根据A列序号合并A列
        RowCount = .Cells.Rows.Count
        LastRow = RowCount

        For i = RowCount To 2 Step -1
            If .Cells(i, "A").Value <> .Cells(i - 1, "A").Value Then     '若前后行内容不同
                FirstRow = i    '记下合并区域的起始行

                .Cells(FirstRow, "A").Resize(LastRow - FirstRow + 1, 1).Merge    '拓展选区
                .Cells(FirstRow, "B").Resize(LastRow - FirstRow + 1, 1).Merge    '拓展选区
                .Cells(FirstRow, "C").Resize(LastRow - FirstRow + 1, 1).Merge    '拓展选区
                .Cells(FirstRow, "D").Resize(LastRow - FirstRow + 1, 1).Merge    '拓展选区

                LastRow = i - 1    '调整下一个区域的终止行
            End If
        Next i


    End With
    Application.DisplayAlerts = True    '恢复警告提示
End Sub
Private Sub SetEdges(ByVal Rng As Range)
    With Rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter

        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        If .Cells.Count > 1 Then
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        End If
    End With
End Sub