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

吴中泉

我也来一个


Sub ssjss()
Dim arr, i, d, d1
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheets("数据整合2").Range("a1").CurrentRegion '
    arr = .Value
    For i = 2 To UBound(arr)
        If arr(i, 12) = Empty Then
            d(arr(i, 2)) = arr(i, 7)  '
            d1(arr(i, 2)) = d1(arr(i, 2)) + 1 '
        End If
    Next
    With Sheets("TRC留5K")
    .[a1].CurrentRegion.Offset(1).ClearContents
    .[a2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    .[b2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
    .[c2].Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.items)
    .[a1].CurrentRegion.Sort Key1:=Range("C2"), Order1:=xlAscending
    End With
    '第三个需求不理解
    Set d = Nothing
    Set d1 = Nothing
End With
End Sub

sampsonpon

感谢所有人的帮助！

吴中泉

sampsonpon

清风竹- 发表于 2023-5-2 15:14
请看附件。

您的代码是不是好像没有考虑到：3、按顺序,有条件选取A列复制到E2:E(条件:当B列和值达到小于等于B列总和-5000即可,不足5000全选)

Sub 筛选出()
Dim d As Object, a, b
Dim ss$, n%, i%
Sheet2.UsedRange.Offset(1, 0) = ""
m = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
a = Sheet1.Range("a1:l" & m)
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 5)
For i = 2 To UBound(a)
   If a(i, 12) = "" Then
     ss = a(i, 2)
     If Not d.Exists(ss) Then
      n = n + 1
      d.Add ss, n
      b(n, 1) = a(i, 2): b(n, 2) = a(i, 7): b(n, 3) = 1: b(n, 5) = b(n, 1)
     Else
       b(d(ss), 3) = b(d(ss), 3) + 1
   End If
End If
Next
[a2].Resize(n, 5) = b
Range("a1:e" & n + 1).Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=1
End Sub

sampsonpon

3190496160 发表于 2023-5-2 15:22
用这个吧

您的代码是不是好像没有考虑到：3、按顺序,有条件选取A列复制到E2:E(条件:当B列和值达到小于等于B列总和-5000即可,不足5000全选)

Sub 筛选出()
Dim d As Object, a, b
Dim ss$, n%, i%
Sheet2.UsedRange.Offset(1, 0) = ""
m = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
a = Sheet1.Range("a1:l" & m)
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 5)
For i = 2 To UBound(a)
   If a(i, 12) = "" Then
     ss = a(i, 2)
     If Not d.Exists(ss) Then
      n = n + 1
      d.Add ss, n
      b(n, 1) = a(i, 2): b(n, 2) = a(i, 7): b(n, 3) = 1: b(n, 5) = b(n, 1)
     Else
       b(d(ss), 3) = b(d(ss), 3) + 1
   End If
End If
Next
[a2].Resize(n, 5) = b
Range("a1:e" & n + 1).Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=1
End Sub

sampsonpon

3190496160 发表于 2023-5-2 15:22
用这个吧

稍微改了一下数据，第3条不正确而且报错

sampsonpon

清风竹- 发表于 2023-5-2 15:14
请看附件。

没有考虑到这一条：3、按顺序,有条件选取A列复制到E2:E(条件:当B列和值达到小于等于B列总和-5000即可,不足5000全选)

吴中泉

sampsonpon 发表于 2023-5-2 16:05
没有考虑到这一条：3、按顺序,有条件选取A列复制到E2:E(条件:当B列和值达到小于等于B列总和-5000即可,不 ...

就是这句我不理解，能详细解释一下吗？
我这样理解对不对：比如A3单元格里手机号18332890478重复了2次，那B3里157也重复2次，和是157+157，或157*2，这个和值小于等于B列总和-5000,就复制这个手机号到E列相应的行中。

sampsonpon

吴中泉 发表于 2023-5-2 16:18
就是这句我不理解，能详细解释一下吗？
我这样理解对不对：比如A3单元格里手机号18332890478重复了2次， ...

意思就是：C列升序后，按从上往下顺序选取A列复制粘贴到E2，直到相应的B列和到达B列总和减去5000为止

吴中泉

sampsonpon 发表于 2023-5-2 16:32
意思就是：C列升序后，按从上往下顺序选取A列复制粘贴到E2，直到相应的B列和到达B列总和减去5000为止

好像懂了，晚上有时间弄一下