Dùng Code nào để cho ra kết quả là tỷ giá gần nhất của 1 ngày

[cadafi]

Chào các anh chị,
Em có một vấn đề sau:
Em có một danh mục tỉ giá theo ngày như sau:

|

A​

|

B​

|

C​

|

D​

|

1​

|

CURY ID​

|

RATE DATE​

|

BASE CURY ID​

|

CURY RATE​

|

2​

|USD|

01/01/2008​

|VND|

16590​

|

3​

|DKK|

01/01/2008​

|USD|

5.7​

|

4​

|USD|

12/09/2008​

|VND|

17890​

|

5​

|USD|

14/09/2008​

|VND|

17891​

|

6​

|USD|

16/09/2008​

|VND|

17892​

|

7​

|USD|

18/09/2008​

|VND|

17893​

|

8​

|USD|

20/09/2008​

|VND|

17894​

|

9​

|USD|

22/09/2008​

|VND|

17895​

|

10​

|USD|

24/09/2008​

|VND|

17896​

|

11​

|USD|

26/09/2008​

|VND|

17897​

|

12​

|USD|

28/09/2008​

|VND|

17898​

|

13​

|USD|

30/09/2008​

|VND|

17899​

|

14​

|USD|

02/10/2008​

|VND|

17900​

|

15​

|USD|

04/10/2008​

|VND|

17901​

|

16​

|USD|

06/10/2008​

|VND|

17902​

|

17​

|USD|

08/10/2008​

|VND|

17903​

|

18​

|USD|

10/10/2008​

|VND|

17904​

|

19​

|USD|

12/10/2008​

|VND|

17905​

|<== Lấy tỷ giá này

20​

|USD|

14/10/2008​

|VND|

17906​

|

21​

|USD|

16/10/2008​

|VND|

17907​

|

22​

|USD|

18/10/2008​

|VND|

17908​

|

23​

|USD|

20/10/2008​

|VND|

17909​

|

24​

|USD|

22/10/2008​

|VND|

17910​

|

25​

|USD|

24/10/2008​

|VND|

17911​

|

26​

|USD|

26/10/2008​

|VND|

17912​

|

27​

|USD|

28/10/2008​

|VND|

17913​

|

Khi ta chọn một ngày bất kỳ, macro sẽ chọn ra tỷ giá của ngày gần nhất (Ngày tỷ giá <= ngày tham chiếu)
Ví dụ: Khi ta chọn ngày 13/10/2008 thì ngày gần nhất trong danh mục là ngày 12/10/2008 ==> lấy tỷ giá 17.905 điền vào 1 ô nào đó.
Xin các anh chị xem file đính kèm.
Xin các anh chị cho em giải pháp bằng VBA càng gọn càng tốt! Em xin cảm ơn!

 

[Po_Pikachu]

Cái này bác Kiệt có trêu mọi người không vậy?
Bác có thể dùng Vlookup, hoặc hàm gì đó xác định cận gần nhất (cận trên - cận dưới) của ngày rồi Offset sang phải là xong ngay?
Thân.

 

[cadafi]

Cái này bác Kiệt có trêu mọi người không vậy?
Bác có thể dùng Vlookup, hoặc hàm gì đó xác định cận gần nhất (cận trên - cận dưới) của ngày rồi Offset sang phải là xong ngay?
Thân.

Cách dùng công thức thì mình biết rồi! Mình cần giải pháp bằng VBA (không dùng Name, không dùng công thức excel)! Gán thẳng giá trị tìm được vào 1 ô nào đó!
Mình đã thử điền công thức mảng bằng VBA vào ô đó dùng FormulaArray nhưng không được. Vì hình như FormulaArray chỉ chấp nhận công thức với cách nhập R1C1, mà nhìn vào đó thì bó tay! Mình cần giải pháp/thuật giải bằng VBA.

 

[Po_Pikachu]

Đơn giản vậy thôi!

Function curyR(vung As Range, ngay As Date)
For Each cel In vung.Offset(, 1).Resize(, 1)
If cel <= ngay Then
temp = cel
End If
Next
curyR = vung.Find(temp).Offset(, 2).Resize(, 1)
End Function

=curyR(A2:D55,H1)

Thân.

 

[ChanhTQ@]

Cái này sẽ nhanh hơn nè

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [h1]) Is Nothing Then
    Dim Rng As Range, sRng As Range:                        Dim jJ As Integer
    
    Set Rng = Range([b1], [b1].End(xlDown))
    Rng.NumberFormat = "MM/DD/YYYY"
    Set sRng = Rng.Find(Format(Target.Value, "Short Date"), , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        Do
            jJ = jJ + 1:                        If jJ = Rng.Rows.Count Then Exit Sub
            Set sRng = Rng.Find(Format(Target.Value + jJ, "Short Date"), , xlFormulas)
            If Not sRng Is Nothing Then
                [h2].Value = sRng.Offset(-1, 2):            Exit Do
            End If
        Loop
    Else
        [h2].Value = sRng.Offset(, 2)
    End If
 End If
End Sub

 

[hai2hai]

Dùng VBA, viết truy cập Sheet như database (giống A-Excel của Tuân đó) như sau:

SELECT TOP 1 CURY_RATE FROM tb_CurencyRateHistory WHERE RATE_DATE <= '10/13/2008' ORDER BY RATE_DATE DESC

P/S: Tên trường (cột), tên bảng (Sheet) không nên viết hoa như ở trên vì khi viết SQL sẽ ko phân biệt được với từ khóa của SQL (thường được viết hoa)

 

[ndu96081631]

Về phần tìm kiếm thì không có vấn đề, nhưng tôi đang thắc mắc 1 chuyện... ví dụ: nếu gõ vào khung tìm kiếm ngày 1/1/2008 thì ta sẽ lấy tỉ giá nào? Lấy cái đầu tiên tìm thấy (16590) hay lấy cái nhỏ nhất tìm thấy (5.7) ---> Tôi để ý thấy cột A có USD và DKK, cột C có VND và USD ---> Sao không thấy nói gì đến chuyện này nhỉ?

 

[Lệnh Hồ Đại Hiệp]

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [h1]) Is Nothing Then
    Dim Rng As Range, sRng As Range:                        Dim jJ As Integer
    
    Set Rng = Range([b1], [b1].End(xlDown))
    Rng.NumberFormat = "MM/DD/YYYY"
    Set sRng = Rng.Find(Format(Target.Value, "Short Date"), , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        Do
            jJ = jJ + 1:                        If jJ = Rng.Rows.Count Then Exit Sub
            Set sRng = Rng.Find(Format(Target.Value + jJ, "Short Date"), , xlFormulas)
            If Not sRng Is Nothing Then
                [h2].Value = sRng.Offset(-1, 2):            Exit Do
            End If
        Loop
    Else
        [h2].Value = sRng.Offset(, 2)
    End If
 End If
End Sub

Tìm kiếm Date bằng Sub thì không có vấn đề, tuy nhiên tìm kiếm Date bằng UDF lại chẳng hề dễ chút nào.
Không tin thử xem bác ạ.
Không hiểu sao Find, Lookup Function lại không hoạt động trong VBA với Date.

To Po_Pikachu :Sao mình thấy UDF này không chạy nhỉ. Có thể post File lên được không??

--CV--

 

[Po_Pikachu]

Sao bạn không tải file về xem nhỉ?
LayTigia.rar
Thân.

 

[Lệnh Hồ Đại Hiệp]

Sao bạn không tải file về xem nhỉ?
LayTigia.rar
Thân.

Sao máy của mình cứ báo lỗi nhỉ?? Mình cài Office 2003 SP3 rồi mà.
Mở bằng Office 2007 cũng thấy lỗi.

Hay do cài liền cả 2 Office nên bị vậy ???

Chứ cũng có ý tưởng về cái vụ Find này rồi nhưng áp dụng cứ lỗi.

Excel VBA Find Method to Find Dates
Dates In The Find Method

Đau đầu!!

--CV--

 

[Po_Pikachu]

Thử kiểm tra lỗi xem nó bị do đâu?
Tìm trong VBA và thử xem bạn có bị dòng "Option Explicit" không?
Sao code này chạy được code kia thì không?
Thân.

 

[ndu96081631]

Tôi thì down file của Po về chỉ báo lổi có mỗi 1 chổ duy nhất, đó là chưa khai báo biến (cel và Temp)---> Còn lại chạy ngon lành

 

[Po_Pikachu]

Nếu lỗi do chưa khai báo biến thì bạn bỏ chọn mục Require Variable Declaration (VBA -> Tools -> thẻ Editor -> bỏ chọn Require Variable Declaration)
Vậy thì ổn!
Thân.

 

[Lệnh Hồ Đại Hiệp]

Khai báo lại các biến đầy đủ,lỗi vẫn hoàn lỗi.
Thế mới mệt chứ.
Các bác test thử hộ hàm này xem có lỗi không ?? Máy em là bó tay rồi.

Function TyGia(Ngay As Date, MangNgay As Range, MangTyGia As Range) As Long
    On Error Resume Next
    Application.Volatile (False)
    If MangNgay.Columns.Count * MangNgay.Columns.Count <> 1 Then Exit Function
    If Ngay = "" Then Exit Function
    Dim i As Long
    i = WorksheetFunction.Match(Ngay, MangNgay, 1)
    TyGia = MangTyGia(i)
End Function

--CV--

 

[Po_Pikachu]

Lần sau bạn nhớ đem code lên ngay từ đầu nha!

Function TyGia(Ngay As Date, MangNgay As Range, MangTyGia As Range)
    Application.Volatile (False)
    If MangNgay.Columns.Count * MangNgay.Columns.Count <> 1 Then Exit Function
    If Ngay = 0 Then Exit Function
    Dim i As Long
    i = WorksheetFunction.Match(CDbl(Ngay), MangNgay, 1)
    TyGia = MangTyGia(i)
End Function

Thân.

 

[Lệnh Hồ Đại Hiệp]

Lần sau bạn nhớ đem code lên ngay từ đầu nha!

Function TyGia(Ngay As Date, MangNgay As Range, MangTyGia As Range)
    Application.Volatile (False)
    If MangNgay.Columns.Count * MangNgay.Columns.Count <> 1 Then Exit Function
    If Ngay = 0 Then Exit Function
    Dim i As Long
    i = WorksheetFunction.Match(CDbl(Ngay), MangNgay, 1)
    TyGia = MangTyGia(i)
End Function

Thân.

Mình làm code này rồi, tuy nhiên khi test lại bị lỗi nên không dám đưa lên (Bây giờ vẫn còn lỗi). Vì vậy không biết do máy hay do Code nữa.
Nhưng khi thử code của bác thấy cũng lỗi, mà người khác dùng vẫn OK, thiết nghĩ chắc do máy của mình.
Vì vậy mạo muội post lên, hy vọng code chạy được. Không biết có chạy được không.
Chứ không có ý gì cả.

Tuyệt vời đấy, chỉ mỗi cái CDbl mà khác hẳn.
Cảm ơn nhiều

Tuy nhiên UDF của bác vẫn chưa chạy được trên máy em.
-------------------------------------------------------
Code trên có thể sửa thành :

Function TyGia(Ngay As Double, MangNgay As Range, MangTyGia As Range) As Long
    On Error Resume Next
    Application.Volatile (False)
    If MangNgay.Columns.Count * MangNgay.Columns.Count <> 1 Then Exit Function
    Dim i As Long
    i = WorksheetFunction.Match(Ngay, MangNgay, 1)
    TyGia = MangTyGia(i)
End Function

--CV--

 

[cadafi]

Về phần tìm kiếm thì không có vấn đề, nhưng tôi đang thắc mắc 1 chuyện... ví dụ: nếu gõ vào khung tìm kiếm ngày 1/1/2008 thì ta sẽ lấy tỉ giá nào? Lấy cái đầu tiên tìm thấy (16590) hay lấy cái nhỏ nhất tìm thấy (5.7) ---> Tôi để ý thấy cột A có USD và DKK, cột C có VND và USD ---> Sao không thấy nói gì đến chuyện này nhỉ?

Đúng như vậy anh ndu ơi! Do sơ sót nên em viết thiếu. Khi tìm tỷ giá thì phải tìm theo loại tiền tệ (cột A) và theo ngày tỷ giá (cột B). Đại khái viết hàm với ba tham số sau:
[Loại tiền tệ], [Đồng tiền làm cơ sở quy đổi], [ngày lấy tỷ giá]
Trong trường hợp của em:

[Loại tiền tệ]:|USD
[Đồng tiền làm cơ sở quy đổi]:|VND
[ngày lấy tỷ giá]:|12/10/2008

 

[cadafi]

Em có viết đoạn code này, nhưng thấy nó sao sao ấy! Mong các anh chị cải tiến giúp. Có cách nào rút ngắn For..next lại không! Vì như code bên dưới sẽ quét hết cả vùng dữ liệu.
[highlight=vb]
Sub GetExcRate()
Dim mDate As Date
Dim CuryID As String, BaseCuryID As String
Dim rngExcRate As Range, ExcRate As Double
Dim mRng As Range, MaxRow As Long, iR As Long
'---------------------------------------------------
mDate = Sheet1.[C1]
CuryID = Sheet1.[C2]
BaseCuryID = Sheet1.[C3]
MaxRow = Sheet1.[A65536].End(xlUp).Row
'---------------------------------------------------
Set rngExcRate = Sheet1.[C4]
Set mRng = Sheet1.Range("A6" & MaxRow)
'---------------------------------------------------
'Sort Du lieu truoc khi tim:
mRng.Sort Key1:=Range("A7"), Order1:=xlAscending, Key2:=Range("B7") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
'---------------------------------------------------
For iR = 7 To MaxRow
With Sheet1
If (.Cells(iR, "A") = CuryID) And (.Cells(iR, "B") <= mDate) And (.Cells(iR, "C") = BaseCuryID) Then
ExcRate = .Cells(iR, "D").Value
End If
End With
Next iR
rngExcRate.Value = ExcRate
End Sub
[/highlight]

Em nghĩ đến việc AutoFilter theo CuryID, BaseCuryID và RateDate<=mDate rồi dùng For .. Next để quét vùng copy đã filter thôi. Nhưng chưa biết viết code làm sao để excel hiểu chỉ quét vùng đã AutoFilter.

 

[ndu96081631]

Em nghĩ đến việc AutoFilter theo CuryID, BaseCuryID và RateDate<=mDate rồi dùng For .. Next để quét vùng copy đã filter thôi. Nhưng chưa biết viết code làm sao để excel hiểu chỉ quét vùng đã AutoFilter.

Thì ...
For Each Clls in Range(....).SpecialCells(12)....
Quét qua các cell có thuộc tính Visible = True ---> Có vấn đề gì chứ

 

[cadafi]

Thì ...
For Each Clls in Range(....).SpecialCells(12)....
Quét qua các cell có thuộc tính Visible = True ---> Có vấn đề gì chứ

Hehe! Cái vụ SpecialCells mà em quên hoài! Cảm ơn anh ndu!
Tuy nhiên, không biết khi AutoFilter nó lại không ra như ý muốn, có lẽ điều kiện ngày có vấn đề, mong anh sửa giúp
[highlight=vb]
Sub GetExcRate1()
Dim mDate As Date
Dim CuryID As String, BaseCuryID As String
Dim rngExcRate As Range, ExcRate As Double
Dim mRng As Range, mCell As Range, MaxRow As Long, iR As Long
'---------------------------------------------------
mDate = Sheet1.[C1] 'Sheet1.[C1] đã được format dạng ngày "dd/mm/yyyy"
CuryID = Sheet1.[C2]
BaseCuryID = Sheet1.[C3]
MaxRow = Sheet1.[A65536].End(xlUp).Row
'---------------------------------------------------
Set rngExcRate = Sheet1.[C4]
Set mRng = Sheet1.Range("A6" & MaxRow)
'---------------------------------------------------
'Kiểm tra xem sheet có Autofilter chưa:
If Sheet1.AutoFilterMode = True Then Sheet1.AutoFilterMode = False
'---------------------------------------------------
'Autofilter:
mRng.AutoFilter Field:=1, Criteria1:=CuryID
mRng.AutoFilter Field:=2, Criteria1:="<=" & mDate
mRng.AutoFilter Field:=3, Criteria1:=BaseCuryID
'---------------------------------------------------
For Each mCell In Sheet1.Range("A6:A" & MaxRow).SpecialCells(12)
If (mCell = CuryID) And (mCell.Offset(, 1) <= mDate) And (mCell.Offset(, 2) = BaseCuryID) Then
ExcRate = mCell.Offset(, 3).Value
End If
Next mCell
rngExcRate.Value = ExcRate
End Sub
[/highlight]