提取数据问题

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, i&, vTemp, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    ar = [A1:C500].Value
    For i = 2 To UBound(ar)
        If Len(ar(i, 1)) Then If Month(ar(i, 1)) = [f2].Value Then vTemp = ar(i, 1) Else vTemp = Empty
        If vTemp <> Empty Then
             If InStr(ar(i, 3), "收") Then dic(vTemp) = Empty
        End If
    Next i
        
    [H4].CurrentRegion.Offset(1).ClearContents
    If dic.Count Then [H5].Resize(dic.Count) = Application.Transpose(dic.keys)
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

swl4561255

1. Sub test()
   
2. ar = Worksheets("sheet1").UsedRange.Rows.Count
   
3. arr = Range("A2:C" & ar)
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5.   For i = 1 To ar - 1
   
6.     If arr(i, 1) <> "" And Month(arr(i, 1)) = [F2] And Left(arr(i, 3), 1) = "收" Then
   
7.        d(arr(i, 1)) = ""
   
8.     End If
   
9.   Next
   
10. k = d.keys
    
11. For j = 8 To 9
    
12.   If InStr(Cells(4, j), [F2] & "月") Then
    
13.      Cells(4, j).Offset(1, 0).Resize(d.Count, 1) = Application.Transpose(k)
    
14.   End If
    
15. Next
    
16. Set d = Nothing
    
17. End Sub

复制代码