Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1754|回复: 8

请帮忙修改统计代码

[复制链接]
发表于 2019-10-14 10:00 | 显示全部楼层 |阅读模式
本帖最后由 tsx84 于 2019-10-14 12:44 编辑

各位大侠:
  附件“统计”按钮的代码有点出错,请帮忙修改下,谢谢!

测试.rar

28.86 KB, 下载次数: 6

发表于 2019-10-14 11:01 | 显示全部楼层
Sub test()
    Dim A, B, i, j, k
    Sheets(1).Select
    A = Range("a2").CurrentRegion
    i = Application.Count(Range("d3:f" & UBound(A) + 1))
    ReDim B(1 To i, 1 To 5)

    For i = 2 To UBound(A)
        For j = 4 To UBound(A, 2)
            If A(i, j) <> "" Then
                k = k + 1
                B(k, 1) = A(i, 1)
                B(k, 2) = A(1, j)
                B(k, 3) = A(i, 2)
                B(k, 4) = A(i, j)
                B(k, 5) = A(i, 3)
            End If
        Next j
    Next i

    Sheets(3).Select
    Range("a2").CurrentRegion.Offset(1, 0).ClearContents
    Range("a2").Resize(k, UBound(B, 2)) = B
End Sub

1.rar (22.42 KB, 下载次数: 3)
回复

使用道具 举报

 楼主| 发表于 2019-10-14 11:16 | 显示全部楼层
爱疯 发表于 2019-10-14 11:01
Sub test()
    Dim A, B, i, j, k
    Sheets(1).Select

还是会出错,麻烦帮忙修正下。
回复

使用道具 举报

发表于 2019-10-14 11:44 | 显示全部楼层
不知道你说的错误是怎样的?
回复

使用道具 举报

 楼主| 发表于 2019-10-14 11:46 | 显示全部楼层
爱疯 发表于 2019-10-14 11:44
不知道你说的错误是怎样的?

运行的时候提示出错,麻烦帮忙修正下,万分感谢!

测试.rar

28.86 KB, 下载次数: 1

回复

使用道具 举报

发表于 2019-10-14 15:18 | 显示全部楼层

Sub test()
    Dim A, B, i, j, k
    Application.ScreenUpdating = False
    Sheets(1).Select
    A = Range("a2").CurrentRegion
    ReDim B(1 To 10 ^ 4, 1 To 5)

    For i = 3 To UBound(A)
        For j = 4 To UBound(A, 2)
            If A(i, j) <> "" Then
                k = k + 1
                B(k, 1) = A(i, 1) '日期
                B(k, 2) = A(2, j) '姓名
                B(k, 3) = A(i, 2) '款式
                B(k, 4) = A(i, j) '数量
                B(k, 5) = A(i, 3) '单价
            End If
        Next j
    Next i

    Sheets(3).Select
    Rows("2:65536") = ""
    Range("a2").Resize(k, UBound(B, 2)) = B
End Sub

测试2.rar (27.38 KB, 下载次数: 2)
回复

使用道具 举报

 楼主| 发表于 2019-10-14 15:42 | 显示全部楼层
爱疯 发表于 2019-10-14 15:18
Sub test()
    Dim A, B, i, j, k
    Application.ScreenUpdating = False

感谢!
但只能计算1页工作表,能帮忙设置多页工作表计算吗?

测试.rar

28.86 KB, 下载次数: 1

回复

使用道具 举报

发表于 2019-10-14 16:13 | 显示全部楼层
tsx84 发表于 2019-10-14 15:42
感谢!
但只能计算1页工作表,能帮忙设置多页工作表计算吗?

Sub test()
    Dim A, B, i, j, k, s
    Application.ScreenUpdating = False
    ReDim B(1 To 10 ^ 4, 1 To 5)

    For k = 1 To Sheets.Count - 1
        Sheets(k).Select
        A = Range("a2").CurrentRegion
        For i = 3 To UBound(A)
            For j = 4 To UBound(A, 2)
                If A(i, j) <> "" Then
                    s = s + 1
                    B(s, 1) = A(i, 1)    '日期
                    B(s, 2) = A(2, j)    '姓名
                    B(s, 3) = A(i, 2)    '款式
                    B(s, 4) = A(i, j)    '数量
                    B(s, 5) = A(i, 3)    '单价
                End If
            Next j
        Next i
    Next k

    Sheets(Sheets.Count).Select
    Rows("2:65536") = ""
    Range("a2").Resize(s, UBound(B, 2)) = B
End Sub

测试3.rar (28.51 KB, 下载次数: 3)
回复

使用道具 举报

 楼主| 发表于 2019-10-14 16:38 | 显示全部楼层
爱疯 发表于 2019-10-14 16:13
Sub test()
    Dim A, B, i, j, k, s
    Application.ScreenUpdating = False


万分感谢!
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 18:01 , Processed in 0.758321 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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