如何根据原始表关键列统计起止后及行数

yzyyyyyyy

原始表A列，有合并单元格，如何根据A列是否合并单元格，生成目标表 如何根据原始表关键列统计起止后及行数.rar (4.76 KB, 下载次数: 13)

2024-9-3 17:53 上传

点击文件名下载附件

songshihai

试试,挺简单的!!!!!!!!!!!!!!!

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。。
Sub test()
    ReDim arr(1 To 10, 1 To 4)
    With Sheet1
        For i = 5 To .Cells(.Rows.Count, 2).End(3).Row
            If .Cells(i, 1) <> "" Then
                n = n + 1
                arr(n, 1) = .Cells(i, 1)
                arr(n, 2) = Split(Split(.Cells(i, 1).MergeArea.Address, ":")(0), "$")(2)
                arr(n, 3) = Split(Split(.Cells(i, 1).MergeArea.Address, ":")(1), "$")(2)
                arr(n, 4) = arr(n, 3) - arr(n, 2) + 1
            End If
        Next
    End With
    Sheet2.[f3].Resize(n, 4) = arr
    Beep
End Sub

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, r&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
     With Worksheets(1).[A5].CurrentRegion
        ar = .Value
        ReDim br(UBound(ar), 3)
        For i = 1 To UBound(ar)
            If Len(ar(i, 1)) Then dic(ar(i, 1)) = .Cells(i, 1).Row
        Next i
        For j = 0 To dic.Count - 1
            r = r + 1
            br(r, 0) = dic.keys()(j)
            br(r, 1) = dic.items()(j)
            If j = dic.Count - 1 Then
                br(r, 2) = .Cells(UBound(ar), 1).Row
            Else
                br(r, 2) = dic.items()(j + 1) - 1
            End If
            br(r, 3) = br(r, 2) - br(r, 1) + 1
            br(0, 3) = br(0, 3) + br(r, 3)
        Next j
    End With
   
    [F2].Resize(r + 1, 4) = br
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

..................

无关岁月

如何根据原始表关键列统计起止后及行数.7z (12.3 KB, 下载次数: 5)

2024-9-3 19:11 上传

点击文件名下载附件

清风竹-

请看附件。

Qs18

Sub qs()
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1:b" & Sheet1.Cells(Rows.Count, 2).End(3).Row)
ReDim brr(1 To UBound(arr), 1 To 4)
For i = 5 To UBound(arr)
    If arr(i, 1) = Empty Then
        arr(i, 1) = arr(i - 1, 1)
    End If
    s = arr(i, 1)
    If Not dic.exists(s) Then
        m = m + 1
        dic(s) = m
        brr(m, 1) = s
        brr(m, 2) = i
        brr(m, 3) = i
        brr(m, 4) = 1
    Else
        rw = dic(s)
        brr(rw, 3) = i
        brr(rw, 4) = brr(rw, 4) + 1
    End If
Next
Sheet2.Range("f3").Resize(m, UBound(brr, 2)) = brr
End Sub

Qs18

试试..........