Cập nhật dữ liêu có chọn lọc (1 người xem)

[Ductinh]

Nhờ các anh chị giúp em vấn đề này với!
Em muốn đưa giá trị vật tư, nhân công, xe máy (giá trị có màu xanh)
từ Sheet DGR vào sheet BKL
Lưu ý chỉ lấy những mã hiệu có trong sheet DGR
còn các giá trị không có trong sheet DGR thì vẫn giữ nguyên
như trong sheet BKL
Cám ơn các anh chị nhiều!

 

[Ductinh]

Các bạn không giúp mình sao?

 

[Ductinh]

mong các anh chị giúp mình với. cám ơn

 

[doveandrose]

ồ bạn đã chờ đợi 4 năm nay và bây giờ vẫn kiên trì đợi người giúp . tôi đánh giá cao khả năng kiên trì của bạn

 

[Ductinh]

Do đang gặp lại vấn đề xưa nên mong các anh chị giúp đỡ.

 

[gtri]

Mình Có vấn đề phát sinh như thế này nếu có 2 hay nhiều công tác giống nhau (mã hiệu định mức giống nhau) thì nó không thực hiện được (nó chỉ thực hiện với hạng mục đầu tiên còn hạng mục kế tiếp thì không thực hiện). Mong bạn giúp mình lần nữa nha! Cám ơn bạn rất nhiều!

Bạn làm rõ chỗ này xem sao
---
Ý vẫn là nhập vl,nc,máy tử DGR sang BKL?
Mà cũng lạ, thông thường đơn giá riêng có mã giống nhau thì giá phải giống nhau, nếu có thay đổi chiết tính thì có lẽ nên có ký hiệu khác kèm theo

 

[Ductinh]

Ý của mình là khi có từ 2 mã hiệu giống nhau trở lên ở sheet BKL thì cuchuoi trên không hoạt động chạy được.

 

[Ba Tê]

Ý của mình là khi có từ 2 mã hiệu giống nhau trở lên ở sheet BKL thì cuchuoi trên không hoạt động chạy được.

Thay CuChuoi bằng CuiBap này xem sao

Sub CuiBap()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, Tem As String
Dim Rng As Range, Cll As Range, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DGR")
    sArr = .Range(.[A7], .[D65536].End(xlUp)).Resize(, 9).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
For I = 1 To UBound(sArr, 1)
    If sArr(I, 2) <> "" Then
        Tem = sArr(I, 2)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, K
        End If
    End If
        If InStr(sArr(I, 4), "A_") Then
            dArr(K, 1) = sArr(I, 9)
        ElseIf InStr(sArr(I, 4), "B_") Then
            dArr(K, 2) = sArr(I, 9)
        ElseIf InStr(sArr(I, 4), "C_") Then
            dArr(K, 3) = sArr(I, 9)
        End If
Next I
With Sheets("BKL")
    For Each Cll In .Range(.[B7], .[B7].End(xlDown))
        Tem = Cll.Value
        If Dic.Exists(Tem) Then
            Rws = Dic.Item(Tem)
            For J = 1 To 3
                Cll.Offset(, J + 3).Value = dArr(Rws, J)
            Next J
        End If
    Next Cll
End With
Set Dic = Nothing
End Sub

 

[Ductinh]

Vẫn không được bạn ơi. Mong ban giup mình lần nữa. Cám ơn bạn nhiều lắm

 

[Ductinh]

Vẫn không được bạn ơi. Mong ban giup mình lần nữa. Cám ơn bạn nhiều lắm

 

[gtri]

Ý của mình là khi có từ 2 mã hiệu giống nhau trở lên ở sheet BKL thì cuchuoi trên không hoạt động chạy được.

Khi có 2 mã hiệu giống nhau thì so sánh theo tên công tác?
---
Với file này tốt nhất là so sánh theo tên công tác, mã hiệu cũng phụ thuộc tên công tác

 

[Ba Tê]

Vẫn không được bạn ơi. Mong ban giup mình lần nữa. Cám ơn bạn nhiều lắm

Bạn đưa dữ liệu mỗi lần mỗi khác, file bạn gởi ở bài #20 khác, file này: sheet BKL, cột B xen dòng trống "tùm lum" làm sao chạy đúng được.
Bạn tìm dòng lệnh này:

With Sheets("BKL")
    For Each Cll In .Range(.[B7], .[B7].End(xlDown))

Từ B7 mà End xuống đụng dòng trống là ngưng rồi.
Sửa lại thành như vầy:

With Sheets("BKL")
    For Each Cll In .Range(.[B7], .[B65536].End(xlUp))

 

[ronlb]

Mình gửi bạn file đính kèm.

 

[Ductinh]

Nhờ anh giúp thêm một lần nữa nha, vẫn còn 1 mã hiệu VT.J300 chạy không đúng giá trị cụ thể dòng tô màu vàng trong file đính kèm. Xin cám ơn

 

[gtri]

Trong khi chờ đợi, chạy tạm cái này xem sao

Public Sub ToTe()
Dim dic As Object, DGR, Tam, Dau, Cuoi, r As Long, rw As Long

Set dic = CreateObject("scripting.dictionary")
DGR = Sheet2.Range("A7", Sheet2.Range("I65000").End(xlUp).Offset(1))
DGR(UBound(DGR), 2) = 1

For r = 1 To UBound(DGR)
If DGR(r, 2) <> "" And Not dic.exists(DGR(r, 2)) Then
Dau = r
dic.Add DGR(r, 2), Array(0, 0, 0)
Tam = dic.Item(DGR(r, 2))

For rw = r + 1 To UBound(DGR)
If DGR(rw, 2) <> "" Then
Cuoi = rw - 1
Exit For
End If
Next rw

For rw = Dau To Cuoi
If Left(Trim(DGR(rw, 4)), 2) = "A_" Then Tam(0) = DGR(rw, 9)
If Left(Trim(DGR(rw, 4)), 2) = "B_" Then Tam(1) = DGR(rw, 9)
If Left(Trim(DGR(rw, 4)), 2) = "C_" Then Tam(2) = DGR(rw, 9)
Next rw
dic.Item(DGR(r, 2)) = Tam

End If
Next r

With Sheet1
For r = 8 To .Range("B65000").End(xlUp).Row
If dic.exists(.Range("B" & r).Value) Then
Tam = dic.Item(.Range("B" & r).Value)
.Range("F" & r) = Tam(0)
.Range("G" & r) = Tam(1)
.Range("H" & r) = Tam(2)
End If
Next r
End With

Set dic = Nothing
End Sub

 

[Ba Tê]

Nhờ anh giúp thêm một lần nữa nha, vẫn còn 1 mã hiệu VT.J300 chạy không đúng giá trị cụ thể dòng tô màu vàng trong file đính kèm. Xin cám ơn

Lỗi này do sheet DGR có nhiều mã trùng lặp. Do lúc đầu bạn không nói và tôi cũng không biết có trường hợp này.
Nếu bỏ trùng thì tốt, khỏi chỉnh code.
Nếu vẫn muốn để nguyên như vậy thì thay Sub cũ bằng cái này:

Sub CuiBap()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long
Dim Rng As Range, Cll As Range, Rws As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DGR")
    sArr = .Range(.[A6], .[D65536].End(xlUp)).Resize(, 9).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
For I = 2 To UBound(sArr, 1)
    If sArr(I, 2) = Empty Then sArr(I, 2) = sArr(I - 1, 2)
    Tem = sArr(I, 2)
    If Not Dic.Exists(Tem) Then
        K = K + 1
        Dic.Add Tem, K
    Else
        Rws = Dic.Item(Tem)
        If InStr(sArr(I, 4), "A_") Then
            dArr(Rws, 1) = sArr(I, 9)
        ElseIf InStr(sArr(I, 4), "B_") Then
            dArr(Rws, 2) = sArr(I, 9)
        ElseIf InStr(sArr(I, 4), "C_") Then
            dArr(Rws, 3) = sArr(I, 9)
        End If
    End If
Next I
With Sheets("BKL")
    For Each Cll In .Range(.[B7], .[B65536].End(xlUp))
        If Cll.Value <> Empty Then Cll.Offset(, 7).Resize(, 3).Value = "=RC5*RC[-3]" '<---Tặng thêm dòng này'
        Tem = Cll.Value
        If Dic.Exists(Tem) Then
            Rws = Dic.Item(Tem)
            For J = 1 To 3
                Cll.Offset(, J + 3).Value = dArr(Rws, J)
            Next J
        End If
    Next Cll
End With
Set Dic = Nothing
End Sub

 

[Ductinh]

Rất hoàn hảo, xin cám ơn bạn rất nhiều.