筛选、去重、排序、有条件复制粘贴问题。急等！

sampsonpon

如附件描述：
1、首先筛选出"数据整合"L列空白，然后将其B、G列去重后写到A、B列

2、C列计算，A列在"数据整合"B列中重复个数，然后升序
3、按顺序,有条件选取A列复制到E2:E(条件:当B列和值达到小于等于B列总和-5000即可,不足5000全选)

3190496160

Sub 筛选()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With Sheets("数据整合2")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据整合2为空！": End
    ar = .Range("a1:l" & r)
End With
ReDim br(1 To UBound(ar), 1 To 3)
For i = 2 To UBound(ar)
    If Trim(ar(i, 12)) = "" Then
        zd = Trim(ar(i, 2)) & "|" & ar(i, 7)
        t = d(zd)
        If t = "" Then
            k = k + 1
            d(zd) = k
            t = k
            br(k, 1) = ar(i, 2)
            br(k, 2) = ar(i, 7)
        End If
        br(t, 3) = br(t, 3) + 1
    End If
Next i
If k = "" Then MsgBox "没有需要筛选的数据！": End
With Sheets("TRC留5K")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(k, 3) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

Sub 筛选()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With Sheets("数据整合2")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据整合2为空！": End
    ar = .Range("a1:l" & r)
End With
ReDim br(1 To UBound(ar), 1 To 3)
For i = 2 To UBound(ar)
    If Trim(ar(i, 12)) = "" Then
        zd = Trim(ar(i, 2)) & "|" & ar(i, 7)
        t = d(zd)
        If t = "" Then
            k = k + 1
            d(zd) = k
            t = k
            br(k, 1) = ar(i, 2)
            br(k, 2) = ar(i, 7)
            hj = hj + ar(i, 7)
        End If
        br(t, 3) = br(t, 3) + 1
    End If
Next i
If k = "" Then MsgBox "没有需要筛选的数据！": End
With Sheets("TRC留5K")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(k, 3) = br
    .Columns(5) = Empty
    .[a1].Resize(k + 1, 3).Sort .[a1], 1, , , , , , 1 '
    If hj <= 5000 Then
        .[e2].Resize(k, 1) = .[a2].Resize(k, 1).Value
    Else
        sl = hj - 5000
        For i = 1 To k
            hj = hj + br(i, 2)
            If hj > 5000 Then
                xh = i - 1
                Exit For
            End If
        Next i
        If xh <> "" Then
            .[e2].Resize(xh, 1) = .[a2].Resize(xh, 1).Value
        End If
    End If
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

20230502.rar (27.29 KB, 下载次数: 9)

2023-5-2 14:49 上传

点击文件名下载附件

sampsonpon

3190496160 发表于 2023-5-2 14:49

这里好像没按C列升序

清风竹-

请看附件。

3190496160

sampsonpon 发表于 2023-5-2 15:01
这里好像没按C列升序

.[a1].Resize(k + 1, 3).Sort .[a1], 1, , , , , , 1 '
修改为
.[a1].Resize(k + 1, 3).Sort .[C1], 1, , , , , , 1 '

3190496160

sampsonpon 发表于 2023-5-2 15:01
这里好像没按C列升序

这里的表述就是存在歧义的，
2、C列计算，A列在"数据整合"B列中重复个数，然后升序
究竟是c列还是a列？
目前是按a列排序的
改一句代码即可
[a1], 1, , , , , , 1 '
改为
[c1], 1, , , , , , 1 '

3190496160

用这个吧
20230502.rar (28.13 KB, 下载次数: 9)

2023-5-2 15:22 上传

点击文件名下载附件

sampsonpon

3190496160 发表于 2023-5-2 15:18
这里的表述就是存在歧义的，
2、C列计算，A列在"数据整合"B列中重复个数，然后升序
究竟是c列还是a列？ ...

对对对，是有些歧义