ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 843|回复: 3

如何在两个区域分别进行分类汇总

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-2-22 21:13 | 显示全部楼层 |阅读模式
本帖最后由 crega123 于 2020-2-22 21:43 编辑

步骤一:按上车站、发车时间、车号排序后,把包含有“东莞”字样的行移动到区域最下一行后6行;
步骤二:分别对两下区域进行分类汇总,分类字段为车牌号,然后对车辆号项进行计数汇总,实付项进行求和汇总。
我有步骤一和步骤二的部分代码,不知如何连接起来,请老师指点一下。
步骤一代码:
With ActiveSheet
        Set Rng = Nothing
        For j = 2 To Cells(Rows.Count, 11).End(3).Row
            If InStr(Cells(j, 3), "东莞") > 0 Then
                If Rng Is Nothing Then
                    Set Rng = Cells(j, 1).Resize(1, 11)
                Else
                    Set Rng = Union(Rng, Cells(j, 1).Resize(1, 11))
                End If
            End If
        Next j
        If Not Rng Is Nothing Then Rng.Copy Cells(ActiveSheet.UsedRange.Rows.Count + 7, 1)
Rng.EntireRow.Delete
    End With

步骤二代码:
Dim q As Integer
    q = MsgBox("是否要汇总", 1, "汇总")
    If q = 2 Then Exit Sub
    Application.ScreenUpdating = False
    Dim arr
    With ActiveSheet.UsedRange
        arr = .Range("A2:K" & .Range("d65536").End(xlUp).Row)
    End With
    With Range("a2").Resize(UBound(arr), UBound(arr, 2))
        .Value = arr
        .Sort Key1:=Range("B2").Resize(UBound(arr)), Order1:=xlAscending, Key2:=Range("D2").Resize(UBound(arr)), Order2:=xlAscending, Key3:=Range("E2").Resize(UBound(arr)), Order3:=xlAscending
        arr = Range("B2:B" & Range("C65536").End(xlUp).Row)
    End With
    With Range("A:K")
        .RemoveSubtotal
        .Subtotal GroupBy:=2, Function:=xlCount, TotalList:=Array(2)
        .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(8)  End With
加个条件:如何C列没有“东莞”两个字样的,则不用进行第一步操作。





分类汇总结果样本

分类汇总结果样本

分类汇总样本.zip

23.99 KB, 下载次数: 6

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-23 22:52 | 显示全部楼层
本帖最后由 crega123 于 2020-2-23 23:28 编辑

我想到了,能帮我优化一下代码吗?
Sub 汇总2()
    Dim q As Integer
    q = MsgBox("是否要汇总", 1, "汇总")
    If q = 2 Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next
    With ActiveSheet
        Set rng = Nothing
        For j = 2 To Cells(Rows.Count, 11).End(3).Row
            If InStr(Cells(j, 3), "东莞") > 0 Then
                If rng Is Nothing Then
                    Set rng = Cells(j, 1).Resize(1, 11)
                Else
                    Set rng = Union(rng, Cells(j, 1).Resize(1, 11))
                End If
            End If
        Next j
        If Not rng Is Nothing Then rng.Copy Cells(ActiveSheet.UsedRange.Rows.Count + 7, 1)
        rng.EntireRow.Delete
    End With
    On Error Resume Next
    Dim arr, brr
    arr = Range("A1").CurrentRegion
    With Range("a2").Resize(UBound(arr), UBound(arr, 2))
        .Value = arr
        .Sort Key1:=Range("B2").Resize(UBound(arr)), Order1:=xlAscending, Key2:=Range("D2").Resize(UBound(arr)), Order2:=xlAscending, Key3:=Range("E2").Resize(UBound(arr)), Order3:=xlAscending
        .RemoveSubtotal
        .Subtotal GroupBy:=2, Function:=xlCount, TotalList:=Array(2)
        .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(8)
    End With
    r = Cells(Range("A1").CurrentRegion.Rows.Count, 1).End(xlUp).Row
    Range("a1:k1").Copy Cells(r + 6, 1)
    brr = Cells(Range("A1").CurrentRegion.Rows.Count + 5, 1).CurrentRegion.Select
    With Selection
        .Sort Key1:=Cells(Range("A1").CurrentRegion.Rows.Count + 5, 2), Order1:=xlAscending, Key2:=Cells(Range("A1").CurrentRegion.Rows.Count + 5, 4), Order2:=xlAscending, Key2:=Cells(Range("A1").CurrentRegion.Rows.Count + 5, 5), Order3:=xlAscending
        .RemoveSubtotal
        .Subtotal GroupBy:=2, Function:=xlCount, TotalList:=Array(2)
        .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(8)
        Set DRNG = Intersect(arr, Selection)
        With DRNG
            .Borders.LineStyle = xlContinuous '所有框线
            .HorizontalAlignment = xlCenter '水平对齐=居中
            .VerticalAlignment = xlCenter '垂直对齐=居中
            Set myFon = .Range("B:B,H:H").Font
            With myFon
                .Name = "宋体(正文)"
                .Size = 11
                .Bold = True
                With Range("C:F").Font
                    .Name = "宋体(正文)"
                    .Size = 9
                End With
            End With
        End With
        Dim oWK As Worksheet
        Set oWK = ActiveSheet
        With oWK
            Set oRng = .Range("A:A,G:G,I:K").EntireColumn
            oRng.Hidden = True
        End With
    End With
    Application.ScreenUpdating = True
  End Sub

TA的精华主题

TA的得分主题

发表于 2020-2-24 00:47 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
每个车牌号下面做个汇总吗?

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-24 02:20 | 显示全部楼层
NadrsSaber 发表于 2020-2-24 00:47
每个车牌号下面做个汇总吗?

能帮我优化一下代码吗?我已做好了。代码如下:
Sub 汇总2()
    Dim q As Integer
    q = MsgBox("是否要汇总", 1, "汇总")
    If q = 2 Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next
    With ActiveSheet
        Set rng = Nothing
        For j = 2 To Cells(Rows.Count, 11).End(3).Row
            If InStr(Cells(j, 3), "东莞") > 0 Then
                If rng Is Nothing Then
                    Set rng = Cells(j, 1).Resize(1, 11)
                Else
                    Set rng = Union(rng, Cells(j, 1).Resize(1, 11))
                End If
            End If
        Next j
        If Not rng Is Nothing Then rng.Copy Cells(ActiveSheet.UsedRange.Rows.Count + 7, 1)
        rng.EntireRow.Delete
    End With
    On Error Resume Next
    Dim arr, brr
    With ActiveSheet.UsedRange
        arr = Range("A1").CurrentRegion
    End With
    With Range("a1").Resize(UBound(arr), UBound(arr, 2))
        .Value = arr
        .Sort Key1:=Range("B1").Resize(UBound(arr)), Order1:=xlAscending, Key2:=Range("D1").Resize(UBound(arr)), Order2:=xlAscending, Key3:=Range("E1").Resize(UBound(arr)), Order3:=xlAscending
        .RemoveSubtotal
        .Subtotal GroupBy:=2, Function:=xlCount, TotalList:=Array(2)
        .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(8)
    End With
    r = Cells(Range("A1").CurrentRegion.Rows.Count, 1).End(xlUp).Row
    Range("a1:k1").Copy Cells(r + 7, 1)
    brr = Cells(Range("A1").CurrentRegion.Rows.Count + 5, 1).CurrentRegion.Select
    With Selection
        .Sort Key1:=Cells(Range("A1").CurrentRegion.Rows.Count + 5, 2), Order1:=xlAscending, Key2:=Cells(Range("A1").CurrentRegion.Rows.Count + 5, 4), Order2:=xlAscending, Key2:=Cells(Range("A1").CurrentRegion.Rows.Count + 5, 5), Order3:=xlAscending
        .RemoveSubtotal
        .Subtotal GroupBy:=2, Function:=xlCount, TotalList:=Array(2)
        .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(8)
        .Borders.LineStyle = xlContinuous '所有框线
        .HorizontalAlignment = xlCenter '水平对齐=居中
        .VerticalAlignment = xlCenter '垂直对齐=居中
        .Font.Name = "宋体(正文)"
        .Font.Size = 10
        With Range("A1").CurrentRegion
            .Borders.LineStyle = xlContinuous '所有框线
            .HorizontalAlignment = xlCenter '水平对齐=居中
            .VerticalAlignment = xlCenter '垂直对齐=居中
            .Font.Name = "宋体(正文)"
            .Font.Size = 10
        End With
    End With
    Dim oWK As Worksheet
    Set oWK = ActiveSheet
    With oWK
        Set oRng = .Range("A:A,G:G,I:K").EntireColumn
        oRng.Hidden = True
        Application.ScreenUpdating = True
    End With
End Sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 21:19 , Processed in 0.053677 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表