添加表名称及汇总行

zjgldy

请老师赐教，要如何实现在数据中引用表名称及插入合计行并汇总，呈上附件请帮助！

添加表名称及汇总行.rar (35.97 KB, 下载次数: 5)

2019-5-4 11:53 上传

点击文件名下载附件

weare2

这个应该可以了。。。

lidayu

路过，做个记号

weare2

Sub s()
Dim wh As Worksheet

For Each wh In Worksheets
    With wh
        Set d = CreateObject("scripting.dictionary")
        gs = .Name
        arr = .Range("a1:a" & .Cells(Rows.Count, 1).End(3).Row - 1)
        For i = 1 To UBound(arr)
            If arr(i, 1) = "" Then
                arr(i, 1) = arr(i - 1, 1)
            End If
        Next
            .Columns("a:a").UnMerge
            .Range("a1").Resize(UBound(arr, 1), 1) = arr
            ar = .Range("a1:a" & .Cells(Rows.Count, 1).End(3).Row - 1)
        For Each rs In ar
            d(rs) = ""
        Next
            For Each rn In d.keys
            w = WorksheetFunction.Match(rn, .Range("a1", .[a1].End(4)), 0)
            ws = WorksheetFunction.CountIf(.Range("a1", .[a1].End(4)), rn)
                .Range("A" & w).EntireRow.Insert
                .Range("A" & w & ":B" & w).Merge
                .Range("a" & w) = "119消防二级消防士套式肩章"
                .Range("a" & w)(1, 3).Resize(1, 3) = Array("合计", "大号", "小号")
                .Range("A" & w + ws + 1).EntireRow.Insert
                .Range("A" & w + ws + 1) = "合计"
                .Range("A" & w + ws + 1)(1, 3) = WorksheetFunction.Sum(.Range("c" & w + 1 & ":c" & w + ws))
                .Range("A" & w + ws + 1)(1, 4) = WorksheetFunction.Sum(.Range("d" & w + 1 & ":d" & w + ws))
                .Range("A" & w + ws + 1)(1, 5) = WorksheetFunction.Sum(.Range("e" & w + 1 & ":e" & w + ws))
            Next
        For i = .Cells(Rows.Count, 1).End(3).Row To 2 Step -1
            If .Range("a" & i) = .Range("a" & i).Offset(-1, 0) Then
                Application.DisplayAlerts = False
                .Range("a" & i).Offset(-1, 0).Resize(2, 1).Merge
                Application.DisplayAlerts = True
            End If
        Next
Next
    End With
End Sub

zjgldy

weare2 发表于 2019-5-4 18:25
Sub s()
Dim wh As Worksheet

您好，基本是对的，还有个别地方有点问题，麻烦您再帮助，谢谢！

zjgldy

weare2 发表于 2019-5-4 18:25
Sub s()
Dim wh As Worksheet

你好，实际“工作簿”中有很多“工作表”，希望代码能通用与全部工作表，一次性完成。

weare2

zjgldy 发表于 2019-5-4 19:57
你好，实际“工作簿”中有很多“工作表”，希望代码能通用与全部工作表，一次性完成。

一会我看看

zjgldy

weare2 发表于 2019-5-5 07:36
一会我看看

weare2

您好，非常感谢您的帮助。

weare2

Sub s()
Dim rg As Range, wk As Worksheet
Set d = CreateObject("scripting.dictionary")
For Each wk In Worksheets
With wk
    For Each rg In .Range("a1:a" & .Cells(Rows.Count, 1).End(3).Row - 1)
        rgs = rg.MergeArea.Count
        rg.UnMerge
        rg.Resize(rgs) = rg
        d(rg.Value) = ""
    Next
        For Each rn In d.keys
            w = WorksheetFunction.Match(rn, .Range("a1", .[a1].End(4)), 0)
            ws = WorksheetFunction.CountIf(.Range("a1", .[a1].End(4)), rn)
                .Range("A" & w).EntireRow.Insert
                .Range("A" & w & ":B" & w).Merge
                .Range("a" & w) = "119消防二级消防士套式肩章"
                .Range("a" & w)(1, 3).Resize(1, 3) = Array("合计", "大号", "小号")
                .Range("A" & w + ws + 1).EntireRow.Insert
                .Range("A" & w + ws + 1) = "合计"
                .Range("A" & w + ws + 1)(1, 3) = WorksheetFunction.Sum(.Range("c" & w + 1 & ":c" & w + ws))
                .Range("A" & w + ws + 1)(1, 4) = WorksheetFunction.Sum(.Range("d" & w + 1 & ":d" & w + ws))
                .Range("A" & w + ws + 1)(1, 5) = WorksheetFunction.Sum(.Range("e" & w + 1 & ":e" & w + ws))
            Next
        For i = .Cells(Rows.Count, 1).End(3).Row To 2 Step -1
            If .Range("a" & i) = .Range("a" & i).Offset(-1, 0) Then
                Application.DisplayAlerts = False
                .Range("a" & i).Offset(-1, 0).Resize(2, 1).Merge
                Application.DisplayAlerts = True
            End If
        Next

End With
d.RemoveAll
Next
End Sub

zjgldy

weare2 发表于 2019-5-5 18:56
Sub s()
Dim rg As Range, wk As Worksheet
Set d = CreateObject("scripting.dictionary")

weare2

你好，感谢你耐心帮助，还有点小要求，请您再修改下，1，把表名称及合计，大号，小号，汇总数值，合计字样加粗。2，汇总如为“0”则显示空白。3，你上传的工作簿上有密码？

字体加粗

汇总值“0”时显示为空白

有工程密码