20161212xlVBA工作表数据整理合并单元格

Posted 2020-09-27 Excel VBA 小天地

Sub NextSeven_CodeFrame()
‘应用程序设置
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    ‘错误处理
    On Error GoTo ErrHandler

    ‘计时器
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer

    ‘变量声明
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim oSht As Worksheet
    Dim i&, j&

    Dim Rng As Range
    Dim Arr As Variant
    Dim EndRow As Long
    Dim RowCount As Long
    Dim ColCount As Long

    Dim FilePath As String




    ‘实例化对象
    Set Wb = Application.ThisWorkbook


    ‘选取单个文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .InitialFileName = Wb.Path    ‘指定初始化路径
        .Filters.Clear
        .Filters.Add "Excel文件", "*.xls;*.xlsx"
        If .Show = -1 Then
            FilePath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    Set OpenWb = Application.Workbooks.Open(FilePath)
    Set oSht = OpenWb.Worksheets(1)
    With oSht
        Set Rng = Application.Intersect(.UsedRange.Offset(1), .UsedRange)
        RowCount = Rng.Rows.Count
        ColCount = Rng.Columns.Count
        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
            ‘长数字加单引号
            Arr(i, 2) = "‘" & Arr(i, 2)
            Arr(i, 10) = "‘" & Arr(i, 10)
            Arr(i, 14) = "‘" & Arr(i, 14)
            Arr(i, 15) = "‘" & Arr(i, 15)
            Arr(i, 18) = "‘" & Arr(i, 18)
            ‘转置关系
            Arr(i, 20) = Arr(i, 2)
            Arr(i, 2) = Arr(i, 1)
            Arr(i, 1) = ""




        Next i
    End With
    OpenWb.Close False

    Set Sht = Wb.Worksheets(1)
    With Sht
        .UsedRange.Offset(6).Clear    ‘预先清除
        Set Rng = .Range("A7").Resize(RowCount, ColCount)
        Rng.Value = Arr    ‘导入内容
    End With

    Dim RowStart As Object
    Dim RowsCount As Object
    Dim Key As String
    Dim OneKey As Variant
    Set RowStart = CreateObject("scripting.dictionary")
    Set RowsCount = CreateObject("scripting.dictionary")

    MergeColumnNo = 2    ‘关键字所在列

    For i = LBound(Arr, 1) To UBound(Arr, 1)
        Key = CStr(Arr(i, MergeColumnNo))
        If RowStart.Exists(Key) = False Then
            RowStart(Key) = i
            RowsCount(Key) = 1
        Else
            RowsCount(Key) = RowsCount(Key) + 1
        End If
    Next i

    MergeCols = Array("A", "B", "D", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Z")    ‘合并列
    For Each OneKey In RowStart.Keys
        For n = LBound(MergeCols) To UBound(MergeCols)
            Rng.Cells(RowStart(OneKey), MergeCols(n)).Resize(RowsCount(OneKey), 1).Merge
        Next n
    Next OneKey

    Const HeadRow As Long = 6
    Dim Index As Long
    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
        Index = 0
        For i = HeadRow + 1 To EndRow
            If .Cells(i, 2).Value <> "" Then
                Index = Index + 1
                .Cells(i, 1).Value = Index
            End If
        Next i
    End With

    SetEdges Rng
    CustomFormat Rng
    Union(Sht.Range("A6:Z6"), Rng).Columns.AutoFit

    ‘运行耗时
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次运行耗时：" & Format(UsedTime, "0.0000000秒") & "——NextSeven竭诚为您服务。" 
ErrorExit:        ‘错误处理结束，开始环境清理
    Set Wb = Nothing
    Set OpenWb = Nothing
    Set Sht = Nothing
    Set oSht = Nothing
    Set Rng = Nothing

    Set RowStart = Nothing
    Set RowsCount = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "错误提示！"
        ‘Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub
Sub CustomFormat(ByVal Rng As Range)
    With Rng
        .Font.Name = "宋体"
        .Font.Size = 10
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
End Sub