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

yzxiongvip · 发表于 2011-1-7 15:08

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

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

yzxiongvip · 发表于 2011-1-7 17:45

谢谢六楼和七楼的代码，不跨月就可以，但是如果是跨月呢，就不行了，比如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 · 发表于 2011-1-7 16:37

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 · 发表于 2011-1-7 16:38

原帖由 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 · 发表于 2011-1-7 16:52

谢谢“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 · 发表于 2011-1-7 16:55

谢谢“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 · 发表于 2011-1-7 17:31

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 Month(arr(i, 1)) = d1 And Day(arr(i, 1)) >= d2 _
And Day(arr(i, 1)) <= d2 + 3 Then
arrt(i, 1) = "'" & d1 & "-" & Day(arr(i, 1))
Do While Day(arr(i, 1)) + 1 = Day(arr(i + 1, 1)) _
And Month(arr(i, 1)) = Month(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

复制代码

近似值以3为例。

zhaogang1960 · 发表于 2011-1-7 17:37

没有看出来规律，猜一猜看对不对：
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 · 发表于 2011-1-7 18:20

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 · 发表于 2011-1-7 18:58

试试：
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

		自动登录	找回密码
密码			免费注册

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

回复 2楼 fsyyyy 的帖子

回复 3楼 zhaogang1960 的帖子

回复 5楼 yzxiongvip 的帖子

回复 8楼 yzxiongvip 的帖子