VBA判断及提取数据, 排序及统计

On_fire

VBA判断及提取数据, 排序及统计

*

Sheet1是源数据,

R及S同行两列是要判断及计算的数据区域

( *其它数据暂时删除 )

*

代码的逻辑如下,

1.      上到下, 顺序判断S列有Bold的字, COPY同行两列到AA及AB列

2.      根据AB列的值做升序 ( 由小到大 )

3.      上到下, 左到右顺序统计AA列的字符, 输出到AE~AG列

4.      AE列是输出序号, AF列是字符, AG列是同行字符的累加统计

*

Sheet1(1)是模拟判断提取

Sheet1(2)是模拟升序, 计算及结果

*

题目有难度,

恳请大神, 老师出手帮忙…祝您新年快乐!

zxsea_7426

On_fire

zxsea_7426 发表于 2022-12-30 20:56

感谢老师,

您的载图答案正确,

但不明白为何代码会报错?

On_fire

zxsea_7426 发表于 2022-12-30 20:56

感谢老师,
已经搞定了!

3190496160

Sub 统计()
Application.ScreenUpdating = False
Dim ar As Variant
Dim rn As Range
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 18).End(xlUp).Row
    For i = 2 To r
        If .Cells(i, 19).Font.Bold = True Then
            If rn Is Nothing Then
                Set rn = .Cells(i, 18).Resize(1, 2)
            Else
                Set rn = Union(rn, .Cells(i, 18).Resize(1, 2))
            End If
        End If
    Next i
    If rn Is Nothing Then MsgBox "没有符合条件的数据！": End
    .Columns("aa:ab") = Empty
    rn.Copy .[aa2]
    rs = .Cells(Rows.Count, 27).End(xlUp).Row
    ar = .Range("aa2:ab" & rs)
    ReDim br(1 To UBound(ar) * 2, 1 To 3)
    For i = 1 To UBound(ar)
        For s = i + 1 To UBound(ar)
            If ar(i, 2) > ar(s, 2) Then
                For j = 1 To 2
                    kk = ar(i, j)
                    ar(i, j) = ar(s, j)
                    ar(s, j) = kk
                Next j
            End If
        Next s
        If InStr(ar(i, 1), "-") > 0 Then
            rr = Split(ar(i, 1), "-")
            For s = 0 To UBound(rr)
                t = d(rr(s))
                If t = "" Then
                    k = k + 1
                    d(rr(s)) = k
                    t = k
                    br(k, 1) = k
                    br(k, 2) = rr(s)
                End If
                br(t, 3) = br(t, 3) + 1
            Next s
        End If
    Next i
    .Range("aa2:ab" & rs) = ar
    .Columns("ae:ag") = Empty
    .[ae2].Resize(k, 3) = br
End With
Set d = Nothing
Set rn = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

range.rar (29.51 KB, 下载次数: 12)

2022-12-31 10:07 上传

点击文件名下载附件