|
第三需求真得好难理解,不知这次理解的可对
- 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
- brr = .UsedRange.Offset(1).Value
- '第三个需求不知理解的要对
- '意思就是:C列升序后,按从上往下顺序选取A列复制粘贴到E2,直到相应的B列和
- '到达B列总和减去5000为止,不足5000全选
- For i = 1 To UBound(brr)
- Bzh = Bzh + brr(i, 2) 'Bzh即B列总和
- Next
- For i = 1 To UBound(brr)
- Ljh = Ljh + brr(i, 2) 'Ljh即累加和
- If Ljh <= Bzh - 5000 Or Ljh < 5000 Then
- brr(i, 5) = brr(i, 1)
- End If
- Next
- .UsedRange.Offset(1) = brr
- End With
- Set d = Nothing
- Set d1 = Nothing
- End With
- End Sub
复制代码 |
|