求助查找近似值代码，谢谢！被”zhaogang1960“圆满解决

yzxiongvip

求助查找近似值代码，谢谢！

[ 本帖最后由 yzxiongvip 于 2011-1-7 20:37 编辑 ]

yzxiongvip

谢谢六楼和七楼的代码，不跨月就可以，但是如果是跨月呢，就不行了，比如C1为”2月26日“（条件值），我要查找到3月2日（离条件值不超过7天），近似值以7为例，同时要实现可跨月查找，要如何改源代码，谢谢！
数据区：
2007-2-2
2007-2-5
2007-2-23
2007-3-24
2007-4-26
2007-12-29
2008-1-6
2008-1-8
2008-2-6
2008-2-7
2008-2-9
2008-3-2
2008-11-22
2009-1-24
2009-1-27
2009-1-29
2009-2-2
2009-2-8
2009-12-9
2010-1-10
2010-2-6
2010-2-14
2010-10-16

[ 本帖最后由 yzxiongvip 于 2011-1-7 18:18 编辑 ]

fsyyyy

Sub Fsyyyy_test()
    d = [c1]
    arr = Range("b3:b" & [b65536].End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        If Month(arr(i, 1)) = Month(d) And Day(arr(i, 1)) >= Day(d) Then brr(i, 1) = Month(arr(i, 1)) & "-" & Day(arr(i, 1))
    Next
    Columns("f:f").NumberFormatLocal = "@"
    [f3].Resize(i - 1) = brr
End Sub

zhaogang1960

原帖由 yzxiongvip 于 2011-1-7 15:08 发表
求助查找近似值代码，谢谢！

数据区是文本格式，如果是真正的日期格式代码要重写：
Sub Macro1()
    Dim cnn As Object
    Dim sql$, s1$, s2$, s3$
    s1 = Month([c1]) & "-" & Day([c1])
    s2 = Month([c1]) & "-" & Day([c1]) + 1
    s3 = Month([c1]) & "-" & Day([c1]) + 2
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName
    sql = "select f1 from [Sheet1$b3:b" & [b65536].End(xlUp).Row & "] where mid(f1,6)='" & s1 & "' or mid(f1,6)='" & s2 & "' or mid(f1,6)='" & s3 & "'"
    sql = "select mid(a.f1,6)  from(" & sql & ") a right join [Sheet1$b3:b" & [b65536].End(xlUp).Row & "] b on a.f1=b.f1"
    [f3].CopyFromRecordset cnn.Execute(sql)
    cnn.Close
    Set cnn = Nothing
End Sub

yzxiongvip

谢谢“fsyyyy”的代码，但比较我要的结果多出了几项,要如何更改源代码，谢谢！

" Fsyyyy"的结果        我要的结果
       
       
2-7                          2-7
       
       
       
       
       
2-6                          2-6
2-7       
2-8       
       
       
       
       
       
       
2-8                           2-8
       
       
2-6                          2-6
2-14

[ 本帖最后由 yzxiongvip 于 2011-1-7 17:06 编辑 ]

yzxiongvip

谢谢“zhaogang1960”的代码，但比较我要的结果多出了两项F11(2-7)和F12(2-8),要如何更改源代码，谢谢！

"zhaogang1960"的结果        我要的结果
       
       
2-7                                          2-7
       
       
       
       
       
2-6                                                2-6
2-7       
2-8       
       
       
       
       
       
       
2-8                                               2-8
       
       
2-6                                               2-6

[ 本帖最后由 yzxiongvip 于 2011-1-7 17:06 编辑 ]

liuguansky

1. Sub justtest()
   
2.     Dim d1%, d2%
   
3.     d1 = Month([c1]): d2 = Day([c1])
   
4.     Dim arr, i&, arrt(), k&
   
5.     arr = Cells(3, 2).Resize(Cells(Rows.Count, 2).End(3).Row - 1, 1).Value
   
6.     ReDim arrt(1 To UBound(arr, 1), 1 To 1)
   
7.     For i = 1 To UBound(arr, 1) - 1
   
8.         If Month(arr(i, 1)) = d1 And Day(arr(i, 1)) >= d2 _
   
9.             And Day(arr(i, 1)) <= d2 + 3 Then
   
10.             arrt(i, 1) = "'" & d1 & "-" & Day(arr(i, 1))
    
11.             Do While Day(arr(i, 1)) + 1 = Day(arr(i + 1, 1)) _
    
12.                 And Month(arr(i, 1)) = Month(arr(i + 1, 1))
    
13.                 i = i + 1
    
14.             Loop
    
15.         End If
    
16.     Next i
    
17.     Range("f3:f" & Rows.Count).Clear
    
18.     Cells(3, "f").Resize(i - 1, 1) = arrt
    
19. End Sub

复制代码

近似值以3为例。

zhaogang1960

没有看出来规律，猜一猜看对不对：
Sub Macro1()
    Dim cnn As Object
    Dim sql$, s1$, s2$, s3$
    s1 = Month([c1]) & "-" & Day([c1])
    s2 = Month([c1]) & "-" & Day([c1]) + 1
    s3 = Month([c1]) & "-" & Day([c1]) + 2
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & ThisWorkbook.FullName
    sql = "select f1 from [Sheet1$b3:b" & [b65536].End(xlUp).Row & "] where mid(f1,6)='" & s1 & "' or mid(f1,6)='" & s2 & "' or mid(f1,6)='" & s3 & "'"
    sql = "select mid(a.f1,6)  from(" & sql & ") a right join [Sheet1$b3:b" & [b65536].End(xlUp).Row & "] b on a.f1=b.f1"
    [f3].CopyFromRecordset cnn.Execute(sql)
    For i = [f65536].End(xlUp).Row To 4 Step -1
        If Len(Cells(i, 6)) Then
            If Len(Cells(i - 1, 6)) Then Cells(i, 6) = ""
        End If
    Next
    cnn.Close
    Set cnn = Nothing
End Sub

liuguansky

Sub justtest()
    Dim d1%, d2%
    d1 = Month([c1]): d2 = Day([c1])
    Dim arr, i&, arrt(), k&
    arr = Cells(3, 2).Resize(Cells(Rows.Count, 2).End(3).Row - 1, 1).Value
    ReDim arrt(1 To UBound(arr, 1), 1 To 1)
    For i = 1 To UBound(arr, 1) - 1
        If  Day(arr(i, 1)) >= d2 _
            And Day(arr(i, 1)) <= d2 + 7 Then
            arrt(i, 1) = "'" & d1 & "-" & Day(arr(i, 1))
            Do While Day(arr(i, 1)) + 1 = Day(arr(i + 1, 1))
                   i = i + 1
            Loop
        End If
    Next i
    Range("f3:f" & Rows.Count).Clear
    Cells(3, "f").Resize(i - 1, 1) = arrt
End Sub

zhaogang1960

试试：
Sub Macro3()
    Dim arr, brr(), y%, Mydate As Date, d%, i&
    Mydate = [c1]
    y = Year(Date)
    arr = Range("B3:B" & [b65536].End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 0)
    For i = 1 To UBound(arr)
        arr(i, 1) = y & "-" & Month(arr(i, 1)) & "-" & Day(arr(i, 1))
        d = DateDiff("d", Mydate, arr(i, 1))
        If d >= 0 And d <= 7 Then
            brr(i, 0) = "'" & Month(arr(i, 1)) & "-" & Day(arr(i, 1))
        End If
    Next
    For i = UBound(arr) To 2 Step -1
        If Len(brr(i - 1, 0)) Then brr(i, 0) = ""
    Next
    [f3].Resize(UBound(arr)) = brr
End Sub