国产一区二区欧美精品免费-欧美国产日韩在线视频-欧美亚洲国语精品一区二区-欧美激情五月综合啪啪-国产69精品麻豆久久久久-亚洲人成精品久久久久桥网站-欧美刺激肥熟在线视频-十七岁日本免费完整版BD-黑夜在线拖拽不卡第一页

希望在打印模塊增加分類打印功能及合并單元格合理分貝功能

這兩個我是通過代碼實現(xiàn)的，代碼也簡單，希望格子能添加進(jìn)去

Sub 篩選指定列不同項分別打印()
    Dim d
    Dim arr(), brr()
    Dim i%, nrow%, s%
    Dim rng As Range
    t = Timer
    Application.ScreenUpdating = False '停止屏幕刷新
    Application.DisplayAlerts = False '停止警告
    Set rng = Application.InputBox("請選擇要篩選打印的單元格！只能選擇一個單元格", Title:="提示", Type:=8)
    srow = rng.Row '選取單元格所在行
    scol = rng.Column '選取單元格所在列
    nrow = Cells(srow, scol).End(xlDown).Row '選取單元格所在列的最后一行
    arr = Range(Cells(srow, scol), Cells(nrow, scol))  '把篩選所在列裝入數(shù)組
    s = UBound(arr)    '一維數(shù)組最后項數(shù)
    Set d = CreateObject("Scripting.Dictionary")    '創(chuàng)建字典對象
    For i = srow + 1 To s  '循環(huán)數(shù)組各項
        d(arr(i, 1)) = ""    '納入字典
    Next
    
    rng.EntireRow.AutoFilter    '選取單元格所在行，即標(biāo)題行
    For i = 1 To d.Count    '循環(huán)字典項
        Selection.AutoFilter Field:=scol, Criteria1:=d.keys()(i - 1)  '以字典各項自動篩選
        ActiveWindow.SelectedSheets.PrintOut   '打印當(dāng)前表
    Next
    Selection.AutoFilter    '取消自動篩選，全部顯示
    Application.ScreenUpdating = True '開啟屏幕刷新
    Application.DisplayAlerts = True '開啟刪除警告
    t = Timer - t
    MsgBox "打印完成，用時" & t & "秒"
End Sub

Sub 重組跨頁合并() '將跨頁的合并單元格重新合并從而適應(yīng)分頁打印
    Dim p, MerageAddress As String, PageCell As Range, MergeValue
    Application.ScreenUpdating = False
    ActiveWindow.View = xlPageBreakPreview '進(jìn)入分頁預(yù)覽，才可以判斷分頁符位置
    For Each p In ActiveSheet.HPageBreaks  '逐頁循環(huán) hpagebreaks對象，打印區(qū)域內(nèi)水平分頁符的集合
        'hpagebreak.location屬性，返回或設(shè)置定義分頁符位置的單元格(range對象)
        Set PageCell = Cells(p.Location.Row - 1, ActiveCell.Column) '將每個分頁最后一個單元格賦予變量
        '如果該頁最后一個單元格具有合并屬性，而且與下一頁第一個單元格處于同一個合并區(qū)域
        If PageCell.MergeCells And Not Intersect(Cells(p.Location.Row, ActiveCell.Column), PageCell.MergeArea) Is Nothing Then
            MerageAddress = PageCell.MergeArea.Address '取得合并區(qū)域的地址
            MergeValue = PageCell.MergeArea(1).Value '取得合并區(qū)域的值
            PageCell.MergeArea.UnMerge '取消合并
            Range(Range(MerageAddress)(1), PageCell).Merge '將合并區(qū)域中處于本頁的單元格合并
            Range(Range(MerageAddress)(1), PageCell).Borders.LineStyle = xlContinuous '添加邊框
            With Range(PageCell.Offset(1, 0), Cells(Split(MerageAddress, "$")(4), ActiveCell.Column))
                .Merge '再將合并區(qū)域中處于下一頁的單元格合并
                .Value = MergeValue '賦值
                .HorizontalAlignment = xlCenter '左右居中
                .VerticalAlignment = xlCenter '上下居中
                .Borders.LineStyle = xlContinuous
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub