Code VBA tra lãi suất theo sản phẩm và thời gian cho trước.

Liên hệ QC
myly

myly

Thành viên mới
Tham gia
25/7/08
Bài viết
33
Được thích
0
Chào mọi người, em đang suy nghĩ về cách viết code VBA để tra lãi suất theo sản phẩm và thời gian cho trước mà nghĩ vẫn chưa ra được. Nay em post file này lên đây hi vọng nếu anh chị nào đã từng biết qua cách viết code cho bài này có thể hướng dẫn giúp em xử lý bài toán này.
Trong file em gửi, em muốn viết Code để chạy ra kết quả như cột K. Em muốn code chạy theo hướng Khung tra điều kiện cho vùng tham chiếu từ C4:F28 để sau này em có thể sử dụng 1 code này cho thêm nhiều dữ liệu.
Xin chân thành cám ơn mọi người
 

File đính kèm

  • Send2forum.xlsx
    9.6 KB · Đọc: 29
Sắp xếp theo thời gian sắp xếp theo bầu chọn
myly đã viết:
Chào mọi người, em đang suy nghĩ về cách viết code VBA để tra lãi suất theo sản phẩm và thời gian cho trước mà nghĩ vẫn chưa ra được. Nay em post file này lên đây hi vọng nếu anh chị nào đã từng biết qua cách viết code cho bài này có thể hướng dẫn giúp em xử lý bài toán này.
Trong file em gửi, em muốn viết Code để chạy ra kết quả như cột K. Em muốn code chạy theo hướng Khung tra điều kiện cho vùng tham chiếu từ C4:F28 để sau này em có thể sử dụng 1 code này cho thêm nhiều dữ liệu.
Xin chân thành cám ơn mọi người
Nhấp chuột vào đây để mở rộng...
Có khả năng trùng ngày không bạn.Ví dụ có 1 mã mà thỏa mãn 2 ngày ấy.Dữ liệu thực tế có dài không bạn để còn lựa viết code.
 
Upvote 0
Không có khả năng trùng ngày đâu bạn. Và dữ liệu thực tế có thể rất dài nên mình mới nghĩ chỉ có cách viết code mới giải quyết được vấn đề này thôi. cám ơn bạn đã quan tâm
 
Upvote 0
myly đã viết:
Không có khả năng trùng ngày đâu bạn. Và dữ liệu thực tế có thể rất dài nên mình mới nghĩ chỉ có cách viết code mới giải quyết được vấn đề này thôi. cám ơn bạn đã quan tâm
Nhấp chuột vào đây để mở rộng...
Bạn thử code này nhé.
Mã: 
Sub laygiatri()
    Dim arr, i As Long, dic As Object, kq, data, s As String, dk As String, lr As Long, T
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         arr = .Range("C5:F" & lr).Value
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
         Next i
         lr = .Range("I" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         data = .Range("I5:J" & lr).Value
         ReDim kq(1 To UBound(data), 1 To 1)
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If dic.exists(dk) Then
                s = dic.Item(dk)
                For Each T In Split(s, "#")
                    If CLng(arr(T, 2)) <= CLng(data(i, 2)) And CLng(arr(T, 3)) >= CLng(data(i, 2)) Then
                       kq(i, 1) = arr(T, 4)
                       Exit For
                    End If
                Next
            End If
        Next i
           .Range("K5:K" & lr).Value = kq
  End With
 
Upvote 0
snow25 đã viết:
Bạn thử code này nhé.
Mã: 
Sub laygiatri()
    Dim arr, i As Long, dic As Object, kq, data, s As String, dk As String, lr As Long, T
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         arr = .Range("C5:F" & lr).Value
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
         Next i
         lr = .Range("I" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         data = .Range("I5:J" & lr).Value
         ReDim kq(1 To UBound(data), 1 To 1)
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If dic.exists(dk) Then
                s = dic.Item(dk)
                For Each T In Split(s, "#")
                    If CLng(arr(T, 2)) <= CLng(data(i, 2)) And CLng(arr(T, 3)) >= CLng(data(i, 2)) Then
                       kq(i, 1) = arr(T, 4)
                       Exit For
                    End If
                Next
            End If
        Next i
           .Range("K5:K" & lr).Value = kq
  End With
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn Snow25 rất nhiều, code của bạn chạy ra đúng kết quả như mong muốn. Vì mình cũng mới bắt đầu tự học VBA gần đây nên trong đoạn code này có nhiều câu lệnh mình chưa biết. Mình sẽ nghiên cứu để học hỏi thêm. Một lần nữa cám ơn sự nhiệt tình giúp đỡ của Snow.
 
Upvote 0
myly đã viết:
Cám ơn bạn Snow25 rất nhiều, code của bạn chạy ra đúng kết quả như mong muốn. Vì mình cũng mới bắt đầu tự học VBA gần đây nên trong đoạn code này có nhiều câu lệnh mình chưa biết. Mình sẽ nghiên cứu để học hỏi thêm. Một lần nữa cám ơn sự nhiệt tình giúp đỡ của Snow.
Nhấp chuột vào đây để mở rộng...
hi Snow, mình đã đọc và nghiền ngẫm code của bạn, có một số chỗ mình không hiểu được. Bạn có thể vui lòng ghi ra gợi ý giúp mình những dòng code mà bạn viết có nghĩa là gì không và code như thế để làm gì. Bạn chỉ giúp mình những dòng code tô đỏ nha. cám ơn bạn rất nhiều.

Sub laygiatri()
Dim arr, i As Long, dic As Object, kq, data, s As String, dk As String, lr As Long, T
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet1")

lr = .Range("C" & Rows.Count).End(xlUp).Row
arr = .Range("C5:F" & lr).Value

For i = 1 To UBound(arr)
dk = arr(i, 1)
If Not dic.exists(dk) Then
dic.Add dk, i
Else
dic.Item(dk) = dic.Item(dk) & "#" & i
End If
Next i
lr = .Range("I" & Rows.Count).End(xlUp).Row
If lr < 5 Then Exit Sub
data = .Range("I5:J" & lr).Value
ReDim kq(1 To UBound(data), 1 To 1)
For i = 1 To UBound(data)
dk = data(i, 1)
If dic.exists(dk) Then
s = dic.Item(dk)
For Each T In Split(s, "#")
If CLng(arr(T, 2)) <= CLng(data(i, 2)) And CLng(arr(T, 3)) >= CLng(data(i, 2)) Then
kq(i, 1) = arr(T, 4)
Exit For
End If
Next
End If
Next i
.Range("K5:K" & lr).Value = kq
End With
End Sub
 
Upvote 0
myly đã viết:
hi Snow, mình đã đọc và nghiền ngẫm code của bạn, có một số chỗ mình không hiểu được. Bạn có thể vui lòng ghi ra gợi ý giúp mình những dòng code mà bạn viết có nghĩa là gì không và code như thế để làm gì. Bạn chỉ giúp mình những dòng code tô đỏ nha. cám ơn bạn rất nhiều.

Sub laygiatri()
Dim arr, i As Long, dic As Object, kq, data, s As String, dk As String, lr As Long, T
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet1")

lr = .Range("C" & Rows.Count).End(xlUp).Row
arr = .Range("C5:F" & lr).Value

For i = 1 To UBound(arr)
dk = arr(i, 1)
If Not dic.exists(dk) Then
dic.Add dk, i
Else
dic.Item(dk) = dic.Item(dk) & "#" & i
End If
Next i
lr = .Range("I" & Rows.Count).End(xlUp).Row
If lr < 5 Then Exit Sub
data = .Range("I5:J" & lr).Value
ReDim kq(1 To UBound(data), 1 To 1)
For i = 1 To UBound(data)
dk = data(i, 1)
If dic.exists(dk) Then
s = dic.Item(dk)
For Each T In Split(s, "#")
If CLng(arr(T, 2)) <= CLng(data(i, 2)) And CLng(arr(T, 3)) >= CLng(data(i, 2)) Then
kq(i, 1) = arr(T, 4)
Exit For
End If
Next
End If
Next i
.Range("K5:K" & lr).Value = kq
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn tìm hiểu mảng và dictionary.
 
Upvote 0
myly đã viết:
Chào mọi người, em đang suy nghĩ về cách viết code VBA để tra lãi suất theo sản phẩm và thời gian cho trước mà nghĩ vẫn chưa ra được. Nay em post file này lên đây hi vọng nếu anh chị nào đã từng biết qua cách viết code cho bài này có thể hướng dẫn giúp em xử lý bài toán này.
Trong file em gửi, em muốn viết Code để chạy ra kết quả như cột K. Em muốn code chạy theo hướng Khung tra điều kiện cho vùng tham chiếu từ C4:F28 để sau này em có thể sử dụng 1 code này cho thêm nhiều dữ liệu.
Xin chân thành cám ơn mọi người
Nhấp chuột vào đây để mở rộng...
Xin chào mọi người, chủ đề này mình đã đăng lên và có bạn đã giải giúp mình nhưng thật sự là sau mấy ngày nghiền ngẫm mình vẫn không thể hiểu được code của bài này. Hi vọng bạn nào biết cách giải khác đơn giản hơn để giúp mình xin cám ơn ah. Cái mình thật sự cần không phải là kết quả mà là cách giải để mình có thể hiểu được tường tận. Mong mọi người giúp đỡ.
 
Upvote 0
myly đã viết:
Xin chào mọi người, chủ đề này mình đã đăng lên và có bạn đã giải giúp mình nhưng thật sự là sau mấy ngày nghiền ngẫm mình vẫn không thể hiểu được code của bài này. Hi vọng bạn nào biết cách giải khác đơn giản hơn để giúp mình xin cám ơn ah. Cái mình thật sự cần không phải là kết quả mà là cách giải để mình có thể hiểu được tường tận. Mong mọi người giúp đỡ.
Nhấp chuột vào đây để mở rộng...
Code bài #4 với giải thuật dùng Dic cao cấp khá phức tạp, nhằm tăng tốc độ xử lý
Mới làm quen với VBA dùng code đơn giản hơn, dữ liệu nhiều tốc độ chậm
Mã: 
Sub ABC()
  Dim sArr(), dArr(), Res()
  Dim rRow As Long, i As Long, r As Long
  Dim iAcc As String, iDate As Date

  With Sheets("sheet1")
    sArr = .Range("C5", .Range("F" & Rows.Count).End(xlUp)).Value
    dArr = .Range("I5", .Range("J" & Rows.Count).End(xlUp)).Value
    ReDim Res(1 To UBound(dArr), 1 To 1)
    For i = 1 To UBound(dArr)
      iAcc = dArr(i, 1)
      iDate = dArr(i, 2)
      For r = 1 To UBound(sArr)
        If iDate >= sArr(r, 2) And iDate <= sArr(r, 3) Then
          If iAcc = sArr(r, 1) Then
            Res(i, 1) = sArr(r, 4)
            Exit For
          End If
        End If
      Next r
    Next i
    .Range("K5").Resize(UBound(dArr)).Value = Res
  End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
myly đã viết:
Chào mọi người, em đang suy nghĩ về cách viết code VBA để tra lãi suất theo sản phẩm và thời gian cho trước mà nghĩ vẫn chưa ra được. Nay em post file này lên đây hi vọng nếu anh chị nào đã từng biết qua cách viết code cho bài này có thể hướng dẫn giúp em xử lý bài toán này.
Trong file em gửi, em muốn viết Code để chạy ra kết quả như cột K. Em muốn code chạy theo hướng Khung tra điều kiện cho vùng tham chiếu từ C4:F28 để sau này em có thể sử dụng 1 code này cho thêm nhiều dữ liệu.
Xin chân thành cám ơn mọi người
Nhấp chuột vào đây để mở rộng...
Bác @HieuCD và @snow25 đã viết code đúng ý cho bạn rồi, tôi cũng không có ý kiến thêm về code.
Tôi góp vui thêm 1 chút là trường hợp này có thể đơn giản dùng công thức thông thường.
1 số lưu ý:
- Để bảng dữ liệu tra cứu ở dạng Table, khi bạn thêm dữ liệu thì vùng tra cứu tự động mở rộng;
- Xem công thức LOOKUP tôi đã viết ở cột L.
Chúc bạn thành công.
 

File đính kèm

  • Tra cuu lai suat.xlsx
    14.9 KB · Đọc: 8
Upvote 0
HieuCD đã viết:
Code bài #4 với giải thuật dùng Dic cao cấp khá phức tạp, tăng tốc độ xử lý
Mới làm quen với VBA dùng code đơn giản hơn, dữ liệu nhiều tốc độ chậm
Mã: 
Sub ABC()
  Dim sArr(), dArr(), Res()
  Dim rRow As Long, i As Long, r As Long
  Dim iAcc As String, iDate As Date

  With Sheets("sheet1")
    sArr = .Range("C5", .Range("F" & Rows.Count).End(xlUp)).Value
    dArr = .Range("I5", .Range("J" & Rows.Count).End(xlUp)).Value
    ReDim Res(1 To UBound(dArr), 1 To 1)
    For i = 1 To UBound(dArr)
      iAcc = dArr(i, 1)
      iDate = dArr(i, 2)
      For r = 1 To UBound(sArr)
        If iDate >= sArr(r, 2) And iDate <= sArr(r, 3) Then
          If iAcc = sArr(r, 1) Then
            Res(i, 1) = sArr(r, 4)
            Exit For
          End If
        End If
      Next r
    Next i
    .Range("K5").Resize(UBound(dArr)).Value = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn
HieuCD đã viết:
Code bài #4 với giải thuật dùng Dic cao cấp khá phức tạp, nhằm tăng tốc độ xử lý
Mới làm quen với VBA dùng code đơn giản hơn, dữ liệu nhiều tốc độ chậm
Mã: 
Sub ABC()
  Dim sArr(), dArr(), Res()
  Dim rRow As Long, i As Long, r As Long
  Dim iAcc As String, iDate As Date

  With Sheets("sheet1")
    sArr = .Range("C5", .Range("F" & Rows.Count).End(xlUp)).Value
    dArr = .Range("I5", .Range("J" & Rows.Count).End(xlUp)).Value
    ReDim Res(1 To UBound(dArr), 1 To 1)
    For i = 1 To UBound(dArr)
      iAcc = dArr(i, 1)
      iDate = dArr(i, 2)
      For r = 1 To UBound(sArr)
        If iDate >= sArr(r, 2) And iDate <= sArr(r, 3) Then
          If iAcc = sArr(r, 1) Then
            Res(i, 1) = sArr(r, 4)
            Exit For
          End If
        End If
      Next r
    Next i
    .Range("K5").Resize(UBound(dArr)).Value = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Xin cám ơn rất nhiều ah. Thật sự là đang vò đầu bức tóc không biết làm thế nào, cách viết này có vẻ giúp em dễ tiếp thu hơn ah. Vì thật sự là mới chuyên tâm học VBA mới được khoảng 1 tháng thôi nên rất cần những cái đơn giản dễ hiểu ah. Em sẽ tiếp tục nghiên cứu và nếu có gì không hiểu sẽ nhờ chỉ giáo thêm ah.
Bài đã được tự động gộp:

vanthinh3101 đã viết:
Bác @HieuCD và @snow25 đã viết code đúng ý cho bạn rồi, tôi cũng không có ý kiến thêm về code.
Tôi góp vui thêm 1 chút là trường hợp này có thể đơn giản dùng công thức thông thường.
1 số lưu ý:
- Để bảng dữ liệu tra cứu ở dạng Table, khi bạn thêm dữ liệu thì vùng tra cứu tự động mở rộng;
- Xem công thức LOOKUP tôi đã viết ở cột L.
Chúc bạn thành công.
Nhấp chuột vào đây để mở rộng...
Dạ xin cám ơn đã chỉ em thêm cách thứ 2 ah. Em cũng sẽ dùng VBA để nhập công thức excel này vào sau đó copy từ trên xuống dưới luôn :)
 
Lần chỉnh sửa cuối:
Upvote 0
snow25 đã viết:
Bạn thử code này nhé.
Mã: 
Sub laygiatri()
    Dim arr, i As Long, dic As Object, kq, data, s As String, dk As String, lr As Long, T
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         arr = .Range("C5:F" & lr).Value
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
         Next i
         lr = .Range("I" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         data = .Range("I5:J" & lr).Value
         ReDim kq(1 To UBound(data), 1 To 1)
         For i = 1 To UBound(data)
             dk = data(i, 1)
             If dic.exists(dk) Then
                s = dic.Item(dk)
                For Each T In Split(s, "#")
                    If CLng(arr(T, 2)) <= CLng(data(i, 2)) And CLng(arr(T, 3)) >= CLng(data(i, 2)) Then
                       kq(i, 1) = arr(T, 4)
                       Exit For
                    End If
                Next
            End If
        Next i
           .Range("K5:K" & lr).Value = kq
  End With
Nhấp chuột vào đây để mở rộng...
Code viết bằng scripting.dictionary nhìn rất hay nhưng thật sự khó ạ. Ngồi ngẫm ngẫm với tra cứu mà vẫn thấy khó ạ !
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11/2024
    • Yêu thích
    • Thích
Trả lời
1
Đọc
58
SA_DQ
SA_DQ
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
32
Đọc
833
VetMini
V
K
Nhờ mọi người hoàn thiện giúp công thức
Trả lời
4
Đọc
93
kiendt1973
K
dovanha1994
Giúp e tìm nguyên nhân sai và hướng dẫn e đọc file này với ạ
    • Phẫn nộ
Trả lời
3
Đọc
97
dovanha1994
dovanha1994
N
Giúp sửa mã code
Trả lời
19
Đọc
403
ptm0412
ptm0412
P
Nhờ giúp đỡ hàm lọc dữ liệu theo tỉnh
Trả lời
10
Đọc
164
Parabol
P
CodyPham97
tạo biểu tượng thay thế nhấn đúp chuột
Trả lời
1
Đọc
54
BuiQuangThuan
B
H
Chúc mừng 20/11- ngày tôn vinh nhà giáo Việt Nam.
    • Thích
    • Yêu thích
Trả lời
0
Đọc
58
HUONGHCKT
H
F
  • Question
Nhờ tư vấn cách tạo QR trong Excel
Trả lời
4
Đọc
448
hoangtuan.net
hoangtuan.net
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
7
Đọc
190
Ny Ny 2024
N
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
9
Đọc
457
bibuzz90
B
Nhật Anh 9x
  • Question
Tính tồn cuối kỳ luỹ kế cho nhiều mã
Trả lời
2
Đọc
97
Nhật Anh 9x
Nhật Anh 9x
H
Hỗ trợ lấy danh sách dữ liệu thỏa mãn điều kiện
Trả lời
1
Đọc
83
bebo021999
B
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
2
Trả lời
20
Đọc
571
ptm0412
ptm0412
nguyen trung cuong
File chứa marco không mở được.
Trả lời
2
Đọc
73
nguyen trung cuong
nguyen trung cuong
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
1
Đọc
114
hvnhpro
H
nobita994
Trừ số lượng dần theo dòng khi quét Sumif tổng có tên sản phẩm bị trùng.
Trả lời
2
Đọc
78
bebo021999
B
PhanTuHuong
Bàn về môn thể thao bóng bàn nào!
    • Thích
    • Yêu thích
    • Cười
2
Trả lời
37
Đọc
2K
cantl
C
S
  • Question
Xin file excel bảng giá quần áo, trang phục, phụ kiện
Trả lời
2
Đọc
79
VetMini
V
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
19
Đọc
388
VetMini
V
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom