统计区域个数

一把小刀闯天下

'跟示例结果不一样？

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Row < 13 Or Target.Row > 33 Or Target.Column < 5 Or Target.Column > 108 Then Exit Sub
  Application.EnableEvents = True
  Dim arr, i, j, title, mark
  ReDim brr(1 To 18, 9)
  arr = [e13:dd33]
  For i = Target.Row - 12 To Target.Row - 12 + 17
    For j = Target.Column - 4 To Target.Column - 4 + 49
      If i <= UBound(arr, 1) And j <= UBound(arr, 2) Then
        brr(i - Target.Row + 12 + 1, Val(Right(arr(i, j), 1))) = _
          brr(i - Target.Row + 12 + 1, Val(Right(arr(i, j), 1))) + 1
      End If
  Next j, i
  title = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
  ReDim mark(1 To UBound(brr, 1), 1 To 1)
  For i = Target.Row To Target.Row + UBound(mark, 1) - 1
    mark(i - Target.Row + 1, 1) = i & "行各数个数"
  Next
  Rows(40).Resize(UBound(arr, 1) + 1).ClearContents
  With Cells(40, Target.Column)
    .Resize(, UBound(title) + 1) = title
    .Offset(1, -4).Resize(UBound(mark, 1)) = mark
    .Offset(1).Resize(UBound(brr, 1), UBound(brr, 2) + 1) = brr
  End With
  Application.EnableEvents = True
End Sub

excelcpeh

lsdongjh 发表于 2018-7-26 13:35

效果是的，不过少统计一行。

lsdongjh

excelcpeh 发表于 2018-7-26 13:46
效果是的，不过少统计一行。

没有少统计，是结果数组是 19行，只显示了前18行，你自己改一下
Set rgSource = shSource.Cells(40, lngColID).Resize(19, 10)

excelcpeh

一把小刀闯天下 发表于 2018-7-26 13:44
'跟示例结果不一样？

Option Explicit

是的，我是做了一个样子。谢谢老师~~~

excelcpeh

excelcpeh 发表于 2018-7-26 13:56
是的，我是做了一个样子。谢谢老师~~~

谢谢老师~！

excelcpeh

lsdongjh 发表于 2018-7-26 13:49
没有少统计，是结果数组是 19行，只显示了前18行，你自己改一下
Set rgSource = shSource.Cells(40, lng ...

感谢老师~！

zhjlgaojuan

Sub test()
Dim SourceArr, MyDic As Object, TargetArr()
Set MyDic = CreateObject("scripting.dictionary")
    SourceArr = Sheet1.[e13].CurrentRegion
    For i = 1 To UBound(SourceArr)
        If Not MyDic.exists(i) Then Set MyDic(i) = CreateObject("scripting.dictionary")
        For j = 1 To UBound(SourceArr, 2)
                MyDic(i)(SourceArr(i, j) Mod 10) = MyDic(i)(SourceArr(i, j) Mod 10) + 1
        Next
    Next
    ReDim TargetArr(1 To MyDic.Count, 0 To 9)
    For i = 1 To UBound(TargetArr)
        For j = 0 To 9
            TargetArr(i, j) = MyDic(i)(j)
        Next
    Next
    Sheet1.Range("k41:t" & [k65535].End(xlUp).Row).CurrentRegion.ClearContents
    Sheet1.[k41].Resize(UBound(TargetArr), 10) = TargetArr
End Sub

YZC51

学习老师的代码
统计个数2.zip (30.85 KB, 下载次数: 18)

2018-7-26 15:55 上传

点击文件名下载附件