提取数据问题

fggf

A列为日期，空白单元格同最接近的往上的日期（例如A10的日期为2024-1-3），C列为收支类型，现要提取A列中按月份列出有收情况的日期。详见附件，谢谢！


提取日期数据1.rar (7.77 KB, 下载次数: 10)

2024-3-31 14:48 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.31
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Cells(Rows.Count, 1).End(3).Row
   
4.     yf = [f2]
   
5.     arr = [a1].Resize(r, 3)
   
6.     For i = 2 To UBound(arr)
   
7.         If Month(arr(i, 1)) = yf Then
   
8.             If InStr(arr(i, 3), "收") Then
   
9.                 s = arr(i, 1)
   
10.                 d(s) = ""
    
11.             End If
    
12.         End If
    
13.     Next
    
14.     ReDim brr(1 To d.Count, 1 To 1)
    
15.     For Each k In d.keys
    
16.         m = m + 1
    
17.         brr(m, 1) = k
    
18.     Next
    
19.     [h5:h10000] = ""
    
20.     Set Rng = [h5].Resize(m, 1)
    
21.     Rng.Value = brr
    
22.     Rng.Sort [h5], 1
    
23.     Set d = Nothing
    
24.     MsgBox "OK！"
    
25. End Sub
    
26. 
    

复制代码

limonet

算了STRSQL做不了，数据不完整，用数组的xy循环吧。

fggf

ykcbf1100 发表于 2024-3-31 15:12
附件供参考。。。

如果1-15和1-17这种情况也要列出来呢，可否帮忙下！

ykcbf1100

fggf 发表于 2024-3-31 15:36
如果1-15和1-17这种情况也要列出来呢，可否帮忙下！

改好了。。。

yanglinzi

请测试。。

shiruiqiang

近期在学sql，练练手

懒得写了，应该是 like 收%

limonet

写到一半我放弃不是风格。
关键字：GetRows+字典

limonet

Sub limonet()
    Dim Cn As Object, Arr As Variant, i%, Dic As Object
    Set Dic = CreateObject("scripting.dictionary")
    Set Cn = CreateObject("Adodb.Connection")
    If Application.Version < 12 Then
        Cn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    Else
        Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    End If
    Arr = Cn.Execute("Select * From [Sheet1$A:C] Where 日期>0 Or [收/支]<>''").GetRows(, , Array("日期", "收/支"))
    For i = 0 To UBound(Arr, 2)
        If Arr(1, i) <> "" Then
            If IsNull(Arr(0, i)) Then Arr(0, i) = Arr(0, i - 1)
            If Month(Arr(0, i)) = [F2] Then Dic(Arr(0, i)) = ""
        End If
    Next i
    Range("F4").Resize(Dic.Count) = Application.Transpose(Dic.keys)
End Sub