Xin Code VBA gán giá trị vào mã hàng trong vùng dữ liệu theo điều kiện thời gian

Liên hệ QC
N

nhodoan

Thành viên mới
Tham gia
6/7/07
Bài viết
4
Được thích
1
Mình xin trợ giúp code vba gán giá trị vào vùng dữ liệu như sau
- Mình có Sheet DATA chứa dữ liệu xuất kho từ tháng 1 đến tháng 12
- Mình muốn cập nhật đơn giá xuất kho trong một khoảng thời gian vào các tháng 3,4,5 vào Sheet DATA mà không làm thay đổi đơn giá các tháng khác.
Nhờ các cao thủ cho mình xin đoạn code VBA này nhé
Cám ơn ah.
 

File đính kèm

  • Gan gia tri vao ma hang theo dieu kien thoi gian.xlsx
    18.4 KB · Đọc: 32
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn cho biết tại sao lại không dùng Vlookup?
 
Upvote 0
nhodoan đã viết:
Mình xin trợ giúp code vba gán giá trị vào vùng dữ liệu như sau
- Mình có Sheet DATA chứa dữ liệu xuất kho từ tháng 1 đến tháng 12
- Mình muốn cập nhật đơn giá xuất kho trong một khoảng thời gian vào các tháng 3,4,5 vào Sheet DATA mà không làm thay đổi đơn giá các tháng khác.
Nhờ các cao thủ cho mình xin đoạn code VBA này nhé
Cám ơn ah.
Nhấp chuột vào đây để mở rộng...
Nếu muốn dùng VBA (dữ liệu lớn-nhiều dòng) thì dùng thử code này xem sao. hy vọng đúng ý.
Mã: 
Sub GIA()
Dim i&, j&, t&, k&, tong&, lr&
Dim Arr(), KQ()
With Sheets("Don gia")
lr = .Cells(Rows.Count, 3).End(xlUp).Row
Arr = .Range("C4:D" & lr).Value
tu = .[G1]: den = .[G2]
End With
With Sheets("DATA")
lr1 = .Cells(Rows.Count, 3).End(xlUp).Row
sArr = .Range("B4:F" & lr1).Value
End With
For i = 1 To UBound(sArr)
    If sArr(i, 1) >= tu And sArr(i, 1) <= den Then
        For j = 1 To UBound(Arr)
            If Arr(j, 1) = sArr(i, 2) Then
                sArr(i, 4) = Arr(j, 2)
            End If
        Next j
    End If
    sArr(i, 5) = sArr(i, 3) * sArr(i, 4)
Next i
Sheets("DATA").[I4].Resize(UBound(sArr), 5).ClearContents
Sheets("DATA").[I4].Resize(UBound(sArr), 5) = sArr
End Sub

Lưu ý: Tôi đang để kết quả trả về vào cột I4:M.... để dễ đối chiếu với số liệu gốc. Bạn có thể đổi sang vị trí khác, nếu muốn
Háy thay đổi một vài số liệu và nhấn nút CHẠY CODE để xem và kiểm tra kết quả.[/code]
 

File đính kèm

  • Gan gia tri vao ma hang theo dieu kien thoi gian( cua NhoDoan).xlsm
    19.7 KB · Đọc: 14
Lần chỉnh sửa cuối:
Upvote 0
Mình cũng hay cập nhật giá kiểu này, bạn xem code tham khảo thêm nhé, mình tách code ra từ file mình đang làm, chỗ nào bạn thấy không cần thiết thì bỏ đi.
 

File đính kèm

  • Gan gia tri vao ma hang theo dieu kien thoi gian.xlsm
    24 KB · Đọc: 11
Upvote 0
nếu bạn muốn kết quả trả về chỉ cập nhật giá trong cột E thì dùng code này.
Mã: 
Sub GIA()
Dim i&, j&, t&, k&, tong&, lr&
Dim Arr(), sArr(), KQ()
With Sheets("Don gia")
lr = .Cells(Rows.Count, 3).End(xlUp).Row
Arr = .Range("C4:D" & lr).Value
tu = .[G1]: den = .[G2]
End With
With Sheets("DATA")
lr1 = .Cells(Rows.Count, 3).End(xlUp).Row
sArr = .Range("B4:F" & lr1).Value
End With
ReDim KQ(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
    KQ(i, 1) = sArr(i, 4)
    If sArr(i, 1) >= tu And sArr(i, 1) <= den Then
        For j = 1 To UBound(Arr)
            If Arr(j, 1) = sArr(i, 2) Then
                KQ(i, 1) = Arr(j, 2)
            End If
        Next j
    End If
Next i
Sheets("DATA").[E4].Resize(UBound(sArr), 1).ClearContents
Sheets("DATA").[E4].Resize(UBound(sArr), 1) = KQ
End Sub
 
Upvote 0
HUONGHCKT đã viết:
nếu bạn muốn kết quả trả về chỉ cập nhật giá trong cột E thì dùng code này.
Nhấp chuột vào đây để mở rộng...
Tôi cũng đoán như bạn về ý của chủ thớt, nhưng tôi chỉ cập nhật đơn giá thôi chứ không sửa công thức cột thành tiền

Bạn hay thiếu khai báo biến, mỗi lần chạy code của bạn tôi lại thấy có báo lỗi vài biến, trong bài này thì thiếu các biến tu, den, lr1, sArr. Tôi luôn cài đặt sẵn để mối lần Insert Module là có ngay dòng Option Explicit trên đầu Module để cảnh báo.
Rich (BB code): 
Sub CapNhatDonGia()
Dim arrData, arrUP
Dim i&, k&, MonthF&, MonthL&
Dim chk As Boolean

    MonthF = Month(Sheet2.Range("G1"))
    MonthL = Month(Sheet2.Range("G2"))
    arrData = Sheet1.Range("B4:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)
    arrUP = Sheet2.Range("C4:D" & Sheet2.Range("C" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(arrData)
        If Month(arrData(i, 1)) >= MonthF And Month(arrData(i, 1)) <= MonthL Then
            For k = 1 To UBound(arrUP)
                If arrUP(k, 1) = arrData(i, 2) Then
                    arrData(i, 4) = arrUP(k, 2)
                    chk = True
                End If
            Next
            If chk = False Then arrData(i, 4) = 0
            chk = False
        End If
    Next
    Sheet1.Range("B4").Resize(UBound(arrData), 4) = arrData
End Sub
 
Upvote 0
nhodoan đã viết:
Mình xin trợ giúp code vba gán giá trị vào vùng dữ liệu như sau
- Mình có Sheet DATA chứa dữ liệu xuất kho từ tháng 1 đến tháng 12
- Mình muốn cập nhật đơn giá xuất kho trong một khoảng thời gian vào các tháng 3,4,5 vào Sheet DATA mà không làm thay đổi đơn giá các tháng khác.
Nhờ các cao thủ cho mình xin đoạn code VBA này nhé
Cám ơn ah.
Nhấp chuột vào đây để mở rộng...
Bạn chỉ cần dùng Vlookup là oki mà
 
Upvote 0
HUONGHCKT đã viết:
nếu bạn muốn kết quả trả về chỉ cập nhật giá trong cột E thì dùng code này.
Mã: 
Sub GIA()
Dim i&, j&, t&, k&, tong&, lr&
Dim Arr(), sArr(), KQ()
With Sheets("Don gia")
lr = .Cells(Rows.Count, 3).End(xlUp).Row
Arr = .Range("C4:D" & lr).Value
tu = .[G1]: den = .[G2]
End With
With Sheets("DATA")
lr1 = .Cells(Rows.Count, 3).End(xlUp).Row
sArr = .Range("B4:F" & lr1).Value
End With
ReDim KQ(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
    KQ(i, 1) = sArr(i, 4)
    If sArr(i, 1) >= tu And sArr(i, 1) <= den Then
        For j = 1 To UBound(Arr)
            If Arr(j, 1) = sArr(i, 2) Then
                KQ(i, 1) = Arr(j, 2)
            End If
        Next j
    End If
Next i
Sheets("DATA").[E4].Resize(UBound(sArr), 1).ClearContents
Sheets("DATA").[E4].Resize(UBound(sArr), 1) = KQ
End Sub
Nhấp chuột vào đây để mở rộng...
Vài gợi ý cho bạn
Code thay thế cho hàm Vlookup nên nghỉ tới Dictionary, dữ liệu kế toán rất nhiều, 2 vòng For lồng nhau chạy rất chậm

Thừa lệnh Sheets("DATA").[E4].Resize(UBound(sArr), 1).ClearContents

lr = .Cells(Rows.Count, 3).End(xlUp).Row
Arr = .Range("C4:D" & lr).Value
Thiếu bẩy lỗi lr<4, tương tự cho sArr = .Range("B4:F" & lr1).Value

Có thể thêm biến nhận giá trị UBound(sArr) và UBound(Arr)
 
Upvote 0
HieuCD đã viết:
Vài gợi ý cho bạn
Code thay thế cho hàm Vlookup nên nghỉ tới Dictionary, dữ liệu kế toán rất nhiều, 2 vòng For lồng nhau chạy rất chậm

Thừa lệnh Sheets("DATA").[E4].Resize(UBound(sArr), 1).ClearContents

lr = .Cells(Rows.Count, 3).End(xlUp).Row
Arr = .Range("C4:D" & lr).Value
Thiếu bẩy lỗi lr<4, tương tự cho sArr = .Range("B4:F" & lr1).Value

Có thể thêm biến nhận giá trị UBound(sArr) và UBound(Arr)
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh đã quan tâm và chỉ giáo.
 
Upvote 0
Maika8008 đã viết:
Tôi cũng đoán như bạn về ý của chủ thớt, nhưng tôi chỉ cập nhật đơn giá thôi chứ không sửa công thức cột thành tiền

Bạn hay thiếu khai báo biến, mỗi lần chạy code của bạn tôi lại thấy có báo lỗi vài biến, trong bài này thì thiếu các biến tu, den, lr1, sArr. Tôi luôn cài đặt sẵn để mối lần Insert Module là có ngay dòng Option Explicit trên đầu Module để cảnh báo.
Rich (BB code): 
Sub CapNhatDonGia()
Dim arrData, arrUP
Dim i&, k&, MonthF&, MonthL&
Dim chk As Boolean

    MonthF = Month(Sheet2.Range("G1"))
    MonthL = Month(Sheet2.Range("G2"))
    arrData = Sheet1.Range("B4:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)
    arrUP = Sheet2.Range("C4:D" & Sheet2.Range("C" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(arrData)
        If Month(arrData(i, 1)) >= MonthF And Month(arrData(i, 1)) <= MonthL Then
            For k = 1 To UBound(arrUP)
                If arrUP(k, 1) = arrData(i, 2) Then
                    arrData(i, 4) = arrUP(k, 2)
                    chk = True
                End If
            Next
            If chk = False Then arrData(i, 4) = 0
            chk = False
        End If
    Next
    Sheet1.Range("B4").Resize(UBound(arrData), 4) = arrData
End Sub
Nhấp chuột vào đây để mở rộng...
Code chạy ra kết quả đúng ý mình,. Cám ơn bác HUONGHCKT và Maika8008 đã giúp đỡ ah !
Bài đã được tự động gộp:

qtm1987 đã viết:
Mình cũng hay cập nhật giá kiểu này, bạn xem code tham khảo thêm nhé, mình tách code ra từ file mình đang làm, chỗ nào bạn thấy không cần thiết thì bỏ đi.
Nhấp chuột vào đây để mở rộng...
Mình đang tạo báo cáo nhập xuất tồn, dùng hàm vlookup thì bị thay đổi giá của các tháng khác, cám ơn bạn nhé !
Bài đã được tự động gộp:

Maika8008 đã viết:
Bạn cho biết tại sao lại không dùng Vlookup?
Nhấp chuột vào đây để mở rộng...
Vì sheet Data chứa dữ liệu hàng nghìn dòng của nhiều tháng khác nhau và có thể biến đổi, mà mình chỉ muốn cập nhật giá cho một số tháng xác định nên mình dùng hàm Vlookup không xử lý đc. Với lại mình muốn dùng code để giảm dung lượng file.
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Vài gợi ý cho bạn
Code thay thế cho hàm Vlookup nên nghỉ tới Dictionary, dữ liệu kế toán rất nhiều, 2 vòng For lồng nhau chạy rất chậm

Thừa lệnh Sheets("DATA").[E4].Resize(UBound(sArr), 1).ClearContents

lr = .Cells(Rows.Count, 3).End(xlUp).Row
Arr = .Range("C4:D" & lr).Value
Thiếu bẩy lỗi lr<4, tương tự cho sArr = .Range("B4:F" & lr1).Value

Có thể thêm biến nhận giá trị UBound(sArr) và UBound(Arr)
Nhấp chuột vào đây để mở rộng...
Viết lại code theo gợi ý của anh HieuCD - dùng dic thay cho nhiều vòng lặp- nên sử dụng trong trường hợp dữ liệu nhiều dòng.
Cảm ơn anh NDU đã có bài mẫu để tôi dựa vào đó mà hoàn thành bài này. Tuy nhiên có thể vẫn không thật hoàn chỉnh (tự cảm nhận thế), mong các anh chị em ghé qua xem code và cho góp ý.
Trân trọng!
Mã: 
v
Public Chk As Boolean, Dic As Object, NapDic()
Sub CapNhatDic()
  Dim Sh As Worksheet, Rng As Range, Arr
  Dim Lr As Long, i As Long, n As Long, m As Long, tmp
  On Error Resume Next
  Set Sh = Sheets("Don gia")
  Lr = Sh.Cells(Rows.Count, 3).End(xlUp).Row
  Arr = Sh.Range("C4:D" & Lr).Value
 ' Arr = Rng.Value
  n = UBound(Arr, 1): m = UBound(Arr, 2)
  ReDim NapDic(1 To n, 1 To m)
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To n
    If CStr(Arr(i, 1)) <> "" Then
      tmp = Arr(i, 1)
      If Not Dic.Exists(tmp) Then
        t = t + 1
        Dic.Add tmp, t
        NapDic(t, 1) = tmp
        NapDic(t, 2) = Arr(i, 2)
      End If
    End If
  Next
End Sub
Sub CapNhat()
Dim i&, Lr&, tu, den
Dim sArr(), KQ(), tmp
If Dic Is Nothing Then CapNhatDic
With Sheets("Don gia")
    tu = .[G1]: den = .[G2]
End With
With Sheets("DATA")
    Lr = .Cells(Rows.Count, 3).End(xlUp).Row
    If Lr <= 4 Then Exit Sub
    sArr = .Range("B4:F" & Lr).Value
End With
ReDim KQ(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
    KQ(i, 1) = sArr(i, 4)
    If sArr(i, 1) >= tu And sArr(i, 1) <= den Then
        tmp = sArr(i, 2)
        If Dic.Exists(tmp) Then KQ(i, 1) = NapDic(Dic.Item(tmp), 2)
    End If
Next i
Sheets("DATA").[E4].Resize(UBound(sArr), 1) = KQ
End Sub
 

File đính kèm

  • Gan gia tri ma hang-Dung dic (cua NhoDoan).xlsm
    24.7 KB · Đọc: 19
Upvote 0
HUONGHCKT đã viết:
Viết lại code theo gợi ý của anh HieuCD - dùng dic thay cho nhiều vòng lặp- nên sử dụng trong trường hợp dữ liệu nhiều dòng.
Cảm ơn anh NDU đã có bài mẫu để tôi dựa vào đó mà hoàn thành bài này. Tuy nhiên có thể vẫn không thật hoàn chỉnh (tự cảm nhận thế), mong các anh chị em ghé qua xem code và cho góp ý.
Trân trọng!
Mã: 
v
Public Chk As Boolean, Dic As Object, NapDic()
Sub CapNhatDic()
  Dim Sh As Worksheet, Rng As Range, Arr
  Dim Lr As Long, i As Long, n As Long, m As Long, tmp
  On Error Resume Next
  Set Sh = Sheets("Don gia")
  Lr = Sh.Cells(Rows.Count, 3).End(xlUp).Row
  Arr = Sh.Range("C4:D" & Lr).Value
 ' Arr = Rng.Value
  n = UBound(Arr, 1): m = UBound(Arr, 2)
  ReDim NapDic(1 To n, 1 To m)
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To n
    If CStr(Arr(i, 1)) <> "" Then
      tmp = Arr(i, 1)
      If Not Dic.Exists(tmp) Then
        t = t + 1
        Dic.Add tmp, t
        NapDic(t, 1) = tmp
        NapDic(t, 2) = Arr(i, 2)
      End If
    End If
  Next
End Sub
Sub CapNhat()
Dim i&, Lr&, tu, den
Dim sArr(), KQ(), tmp
If Dic Is Nothing Then CapNhatDic
With Sheets("Don gia")
    tu = .[G1]: den = .[G2]
End With
With Sheets("DATA")
    Lr = .Cells(Rows.Count, 3).End(xlUp).Row
    If Lr <= 4 Then Exit Sub
    sArr = .Range("B4:F" & Lr).Value
End With
ReDim KQ(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
    KQ(i, 1) = sArr(i, 4)
    If sArr(i, 1) >= tu And sArr(i, 1) <= den Then
        tmp = sArr(i, 2)
        If Dic.Exists(tmp) Then KQ(i, 1) = NapDic(Dic.Item(tmp), 2)
    End If
Next i
Sheets("DATA").[E4].Resize(UBound(sArr), 1) = KQ
End Sub
Nhấp chuột vào đây để mở rộng...
If Dic Is Nothing Then CapNhatDic khá nguy hiểm vì sheet đơn giá thay đổi dic không đổi theo, kết quả sẽ không cập nhật
Viết theo hướng đơn giản sẽ dể kiểm soát hơn, không cần chia 2 sub
Nạp giá trị vào dic chỉ cần lệnh dic.item(Arr(i, 1)) = Arr(i, 2) lấy kết quả KQ(i, 1) = Dic.Item(sArr(i, 2))
 
Upvote 0
HUONGHCKT đã viết:
Viết lại code theo gợi ý của anh HieuCD - dùng dic thay cho nhiều vòng lặp- nên sử dụng trong trường hợp dữ liệu nhiều dòng.
Cảm ơn anh NDU đã có bài mẫu để tôi dựa vào đó mà hoàn thành bài này. Tuy nhiên có thể vẫn không thật hoàn chỉnh (tự cảm nhận thế), mong các anh chị em ghé qua xem code và cho góp ý.
Trân trọng!
Mã: 
v
Public Chk As Boolean, Dic As Object, NapDic()
Sub CapNhatDic()
  Dim Sh As Worksheet, Rng As Range, Arr
  Dim Lr As Long, i As Long, n As Long, m As Long, tmp
  On Error Resume Next
  Set Sh = Sheets("Don gia")
  Lr = Sh.Cells(Rows.Count, 3).End(xlUp).Row
  Arr = Sh.Range("C4:D" & Lr).Value
 ' Arr = Rng.Value
  n = UBound(Arr, 1): m = UBound(Arr, 2)
  ReDim NapDic(1 To n, 1 To m)
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To n
    If CStr(Arr(i, 1)) <> "" Then
      tmp = Arr(i, 1)
      If Not Dic.Exists(tmp) Then
        t = t + 1
        Dic.Add tmp, t
        NapDic(t, 1) = tmp
        NapDic(t, 2) = Arr(i, 2)
      End If
    End If
  Next
End Sub
Sub CapNhat()
Dim i&, Lr&, tu, den
Dim sArr(), KQ(), tmp
If Dic Is Nothing Then CapNhatDic
With Sheets("Don gia")
    tu = .[G1]: den = .[G2]
End With
With Sheets("DATA")
    Lr = .Cells(Rows.Count, 3).End(xlUp).Row
    If Lr <= 4 Then Exit Sub
    sArr = .Range("B4:F" & Lr).Value
End With
ReDim KQ(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
    KQ(i, 1) = sArr(i, 4)
    If sArr(i, 1) >= tu And sArr(i, 1) <= den Then
        tmp = sArr(i, 2)
        If Dic.Exists(tmp) Then KQ(i, 1) = NapDic(Dic.Item(tmp), 2)
    End If
Next i
Sheets("DATA").[E4].Resize(UBound(sArr), 1) = KQ
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn xem cái code này.
Mã: 
Sub capnhap()
   Dim i As Long, lr As Long, arr, dic As Object, ngaybd As Long, ngaykt As Long
   Dim dk As String
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("don gia")
       lr = .Range("C" & Rows.Count).End(xlUp).Row
       arr = .Range("C4:D" & lr).Value
       ngaybd = .Range("G1").Value2
       ngaykt = .Range("G2").Value2
       For i = 1 To UBound(arr)
           dk = arr(i, 1)
           dic.Item(dk) = arr(i, 2)
       Next i
  End With
  With Sheets("DAta")
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       If lr < 4 Then Exit Sub
       arr = .Range("B4:F" & lr).Value
       For i = 1 To UBound(arr)
           If CLng(arr(i, 1)) >= ngaybd And CLng(arr(i, 1)) <= ngaykt Then
              dk = arr(i, 2)
              If dic.exists(dk) Then
                 arr(i, 4) = dic.Item(dk)
                 arr(i, 5) = arr(i, 4) * arr(i, 3)
              End If
           End If
       Next i
       .Range("B4:F" & lr).Value = arr
 End With
End Sub
 
Upvote 0
Cũng mới viết xong, cơ bản nó cũng tựa tựa như nhau. Thêm mảng res chứ không gán mảng gốc sợ có công thức mà bạn không muốn xóa
Mã: 
Option Explicit
Private dic As Object
Private Sub AddKeyToDic(arr(), KeyCol As Long, ItemCol As Long)
'Arr là mang 2 chieu, có ít nhât 2 côt, Gôc (lbound) = 1
Dim i As Long, uB As Long, iKey As String, iItem As Variant
uB = UBound(arr, 1)
If dic Is Nothing Then Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To uB
    If arr(i, KeyCol) <> "" Then
        iKey = arr(i, KeyCol)
        iItem = arr(i, ItemCol)
        dic(iKey) = iItem
    End If
Next
End Sub

Sub UpdateData()
Dim dicArr(), sArr(), Res()
Dim i As Long, J As Long, K As Long, sU1 As Long, sLr As Long, dLr As Long
Dim sItem As String, sDate As Double, fDate As Double, lDate As Double
With Sheets("Don gia")
    dLr = .Cells(Rows.Count, "C").End(xlUp).Row
    If dLr < 4 Then MsgBox "Chua co don gia": Exit Sub
    dicArr = .Range("C4:D" & dLr).Value
    fDate = .Range("G1").Value2: lDate = .Range("G2").Value2
End With
With Sheets("Data")
    sLr = .Cells(Rows.Count, "C").End(xlUp).Row
    If sLr < 4 Then MsgBox "Chua co du lieu": Exit Sub
    sArr = .Range("B4:F" & sLr).Value
    sU1 = UBound(sArr, 1)
    ReDim Res(1 To sU1, 1 To 2)
    AddKeyToDic dicArr, 1, 2
    For i = 1 To sU1
        sDate = sArr(i, 1): sItem = sArr(i, 2)
        If sItem <> "" Then
            If sDate >= fDate And sDate <= lDate Then
                If dic.exists(sItem) Then
                    Res(i, 1) = dic.item(sItem)
                    Res(i, 2) = Res(i, 1) * sArr(i, 3)
                End If
            End If
        End If
    Next
    .Range("E4:F" & Rows.Count).ClearContents
    .Range("E4:F" & sLr) = Res
End With
End Sub
 
Upvote 0
Nhattanktnn đã viết:
Cũng mới viết xong, cơ bản nó cũng tựa tựa như nhau. Thêm mảng res chứ không gán mảng gốc sợ có công thức mà bạn không muốn xóa
Mã: 
Option Explicit
Private dic As Object
Private Sub AddKeyToDic(arr(), KeyCol As Long, ItemCol As Long)
'Arr là mang 2 chieu, có ít nhât 2 côt, Gôc (lbound) = 1
Dim i As Long, uB As Long, iKey As String, iItem As Variant
uB = UBound(arr, 1)
If dic Is Nothing Then Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To uB
    If arr(i, KeyCol) <> "" Then
        iKey = arr(i, KeyCol)
        iItem = arr(i, ItemCol)
        dic(iKey) = iItem
    End If
Next
End Sub

Sub UpdateData()
Dim dicArr(), sArr(), Res()
Dim i As Long, J As Long, K As Long, sU1 As Long, sLr As Long, dLr As Long
Dim sItem As String, sDate As Double, fDate As Double, lDate As Double
With Sheets("Don gia")
    dLr = .Cells(Rows.Count, "C").End(xlUp).Row
    If dLr < 4 Then MsgBox "Chua co don gia": Exit Sub
    dicArr = .Range("C4:D" & dLr).Value
    fDate = .Range("G1").Value2: lDate = .Range("G2").Value2
End With
With Sheets("Data")
    sLr = .Cells(Rows.Count, "C").End(xlUp).Row
    If sLr < 4 Then MsgBox "Chua co du lieu": Exit Sub
    sArr = .Range("B4:F" & sLr).Value
    sU1 = UBound(sArr, 1)
    ReDim Res(1 To sU1, 1 To 2)
    AddKeyToDic dicArr, 1, 2
    For i = 1 To sU1
        sDate = sArr(i, 1): sItem = sArr(i, 2)
        If sItem <> "" Then
            If sDate >= fDate And sDate <= lDate Then
                If dic.exists(sItem) Then
                    Res(i, 1) = dic.item(sItem)
                    Res(i, 2) = Res(i, 1) * sArr(i, 3)
                End If
            End If
        End If
    Next
    .Range("E4:F" & Rows.Count).ClearContents
    .Range("E4:F" & sLr) = Res
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Nếu là thêm mảng mới thì như code trên nó không ghi lại giá trị không cần thay à thiếu mất 1 dòng lệnh ghi lại giá trị cũ nữa.
 
Upvote 0
Upvote 0
HieuCD đã viết:
If Dic Is Nothing Then CapNhatDic khá nguy hiểm vì sheet đơn giá thay đổi dic không đổi theo, kết quả sẽ không cập nhật
Viết theo hướng đơn giản sẽ dể kiểm soát hơn, không cần chia 2 sub
Nạp giá trị vào dic chỉ cần lệnh dic.item(Arr(i, 1)) = Arr(i, 2) lấy kết quả KQ(i, 1) = Dic.Item(sArr(i, 2))
Nhấp chuột vào đây để mở rộng...
Cảm ơn tất cả các anh chị em đan quan tâm xem code và chỉ giáo cho tôi những điều rất hữu ich.
Như tôi đã viết. Code trên tôi làm dựa trên bài mẫu của anh NDU.
Để cập nhật Dic khi sh Đon gia có biến động thì ở SH đon gia đã có code
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("C4:C10000"), Target) Is Nothing Then   Chk = True
End Sub

Private Sub Worksheet_Deactivate()
  If Chk Then
    CapNhatDic
    Chk = False
  End If
End Sub
Còn dòng If Dic Is Nothing Then CapNhatDic thì tôi hiểu là nếu dic rỗng thì cập nhật Dic. như vậy với code ở sự kiện thay đổi C4:C10000 đã cập nhật dic rồi, khi chạy Sub CapNhat lại được kiểm tra lần nữa ==>loại trừ được trường hợp đơn gia không được cập nhật.
Tôi đọc và tự hiểu code mẫu của anh NDU khi phân tách thành 2 sub CapNhatDic và CapNhat để chạy riêng rẽ. Sub CapNhatDic sẽ được lệnh chạy khi có sự thay đổi ở Sh Đongia (range C4:C10000). Khi ra lệnh chạy Sub CapNhat1, Sub CapNhat2...(nếu có) có sử dụng đến Dic thì cứ lấy dic ấy ra mà dùng mà không phải nạp lại dic nữa.
Trên đây là những hiểu biết của tôi khi đọc code của anh NDU và tập tọng viết theo. Kính mong anh chị em xem và chỉ giáo cho những chỗ còn chưa hiểu, hiểu sai hoặc còn có những lỗ hổng kiến thức.
Trân trọng!
 
Lần chỉnh sửa cuối:
Upvote 0
HUONGHCKT đã viết:
Còn dòng If Dic Is Nothing Then CapNhatDic thì tôi hiểu là nếu dic rỗng thì cập nhật Dic. như vậy với code ở sự kiện thay đổi C4:C10000 đã cập nhật dic rồi, khi chạy Sub CapNhat lại được kiểm tra lần nữa ==>loại trừ được trường hợp đơn gia không được cập nhật.
Nhấp chuột vào đây để mở rộng...
Bạn nghĩ sao về trường hợp này nha, mới vào người dùng mở file lên, bấm runcode => Tất cả mọi chuyện vẫn tốt đẹp, nhưng: khi đó dic không còn là nothing nữa.
Sau đó, người ta thay đổi giá, thì code phát hiện ra dic không là nothing nên sẽ bỏ qua sub capnhatdic
Lúc xem code bạn mình cũng thấy điều này bất ổn nhưng bác Hiếu nói rồi nên thôi
 
Upvote 0
nhodoan đã viết:
Mình xin trợ giúp code vba gán giá trị vào vùng dữ liệu như sau
- Mình có Sheet DATA chứa dữ liệu xuất kho từ tháng 1 đến tháng 12
- Mình muốn cập nhật đơn giá xuất kho trong một khoảng thời gian vào các tháng 3,4,5 vào Sheet DATA mà không làm thay đổi đơn giá các tháng khác.
Nhờ các cao thủ cho mình xin đoạn code VBA này nhé
Cám ơn ah.
Nhấp chuột vào đây để mở rộng...
Thử 1 cách khác. Và tiện nhờ mọi người chỉ giáo giúp
Mã: 
Sub ABC()
    Dim arr(), dic As Object, BD, KT, iRow&, i&, sarr(), j&
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Don gia")
        iRow = .Range("C" & Rows.Count).End(3).Row
        BD = .Range("G1").Value
        KT = .Range("G2").Value
        arr = .Range("C4:D" & iRow).Value
    End With
    For i = 1 To UBound(arr, 1)
        If dic.exists(arr(i, 1)) = False Then
            dic.Item(arr(i, 1)) = arr(i, 2)
        End If
    Next
    If dic.Count < 0 Then Exit Sub
    With Sheets("DATA")
        iRow = .Range("C" & Rows.Count).End(3).Row
        sarr = .Range("B4:F" & iRow).Value
    End With
    For i = 1 To UBound(sarr, 1)
        If sarr(i, 1) > BD And sarr(i, 1) < KT Then
            If dic.exists(sarr(i, 2)) = True Then
                j = dic.Item(sarr(i, 2))
                sarr(i, 4) = j
                sarr(i, 5) = sarr(i, 3) * sarr(i, 4)
            End If
        
        End If
    Next
    Sheets("DATA").Range("B4").Resize(UBound(sarr, 1), UBound(sarr, 2)) = sarr
End Sub
 
Upvote 0
Nhattanktnn đã viết:
Bạn nghĩ sao về trường hợp này nha, mới vào người dùng mở file lên, bấm runcode => Tất cả mọi chuyện vẫn tốt đẹp, nhưng: khi đó dic không còn là nothing nữa.
Sau đó, người ta thay đổi giá, thì code phát hiện ra dic không là nothing nên sẽ bỏ qua sub capnhatdic
Lúc xem code bạn mình cũng thấy điều này bất ổn nhưng bác Hiếu nói rồi nên thôi
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn đã quan tâm và chỉ giáo:
Tôi nghĩ là: Khi thay đổi giá thì chạy code ở sự kiện thay đổi Range(C4:C10000) Sh Don gia rồi mà.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("C4:C10000"), Target) Is Nothing Then Chk = True
End Sub
và
Private Sub Worksheet_Deactivate()
If Chk Then
CapNhatDic
Chk = False
End If
End Sub
 
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

H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
18
Đọc
19K
DeTong
D
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
Trả lời
13
Đọc
262
Tuấn Bụng Bự
Tuấn Bụng Bự
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
245
Đọc
13K
Hoàng Trọng Hữu
Hoàng Trọng Hữu
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
277
cantl
C
N
Giúp sửa mã code
Trả lời
16
Đọc
248
ptm0412
ptm0412
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
0
Đọc
34
dung09031989
dung09031989
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
1
Đọc
41
tranvansau278
T
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
0
Đọc
37
cherry0187
C
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
1
Đọc
34
hoangminhtien
hoangminhtien
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
0
Đọc
146
GPE-Trợ Lý
GPE-Trợ Lý
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
2
Đọc
77
phutdm
P
dunghtgiga
  • Đã khóa
Tính bốn tuần cho một tháng
Trả lời
9
Đọc
268
ptm0412
ptm0412
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
3
Đọc
102
HUONGHCKT
H
Mr Đạo
in giấy ra bị lệch xuống dưới
    • Thích
2
Trả lời
29
Đọc
26K
Hoàng Tuấn 868
H
H
Không xem được ảnh trên Excel
Trả lời
3
Đọc
1K
huyentran9292
H
T
Xin form quản lý dữ liệu học viên của Trung tâm Đào tạo
Trả lời
2
Đọc
222
hakiru188
H
C
Code Lọc Dữ Liệu
Trả lời
10
Đọc
175
Cúc Hr
C
Y
Cách ẩn công thức 1 ô trong sheet
Trả lời
8
Đọc
120
hoangminhtien
hoangminhtien
vuha
  • Question
Lỗi chọn dòng thứ 6 trong sheet được chọn: rows("6:6").select
Trả lời
12
Đọc
161
ptm0412
ptm0412
Nguyencaocuong86
Tô màu dữ liệu trùng lặp trong excel.
Trả lời
10
Đọc
145
Nguyencaocuong86
Nguyencaocuong86
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