Cập nhật ngày áp dụng theo điều kiện (1 người xem)

[HocVBAExcel]

Chào các Anh Chị
Hiện tại em có file dữ liệu như sau ,Sheet 1 là file data dữ liệu cần cập nhật ngày áp dụng,sheet2 là danh sách yêu cầu cập nhật.
Nếu chi tiết trong sheet 1 giống trong sheet2 thì cập nhật ngày áp dụng mới ,còn nếu có chi tiết không có trong sheet1 thì cập nhật thêm vào cuối dòng.
Em giúp file ví dụ có kết quả nhớ các anh chị giúp.

 

[ChanhTQ@]

Bạn chạy macro này trên file của bạn, chắc sẽ được:

Option Explicit
Sub CapNhatNgayApDung()
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
 Dim Rws As Long:                       Const mC As Byte = 38
 
 Sheet2.Select
 Set Sh = ThisWorkbook.Worksheets("Sheet1")
 Rws = Sh.[b5].CurrentRegion.Rows.Count
 Set Rng = Sh.[b4].Resize(Rws, 2)
 For Each Cls In Range([b5], [b5].End(xlDown))
    Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        With Sh.[b4].End(xlDown).Offset(1)
            .Resize(, 3).Value = Cls.Resize(, 3).Value
            .Interior.ColorIndex = mC
        End With
    Else
        If sRng.Offset(, 1).Value = Cls.Offset(, 1).Value Then
            sRng.Offset(, 2).Value = Cls.Offset(, 2).Value
            sRng.Offset(, 2).Interior.ColorIndex = mC
        End If
    End If
 Next Cls
 Sh.Select:                             Set Sh = Nothing
End Sub

 

[HocVBAExcel]

Bạn chạy macro này trên file của bạn, chắc sẽ được:

Option Explicit
Sub CapNhatNgayApDung()
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
 Dim Rws As Long:                       Const mC As Byte = 38
 
 Sheet2.Select
 Set Sh = ThisWorkbook.Worksheets("Sheet1")
 Rws = Sh.[b5].CurrentRegion.Rows.Count
 Set Rng = Sh.[b4].Resize(Rws, 2)
 For Each Cls In Range([b5], [b5].End(xlDown))
    Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        With Sh.[b4].End(xlDown).Offset(1)
            .Resize(, 3).Value = Cls.Resize(, 3).Value
            .Interior.ColorIndex = mC
        End With
    Else
        If sRng.Offset(, 1).Value = Cls.Offset(, 1).Value Then
            sRng.Offset(, 2).Value = Cls.Offset(, 2).Value
            sRng.Offset(, 2).Interior.ColorIndex = mC
        End If
    End If
 Next Cls
 Sh.Select:                             Set Sh = Nothing
End Sub

Không đúng kết quả mong muốn anh
Ví dụ như mã hàng A041 của sheet1 là 150114 sẽ cập nhật thành 160116
còn C043 của sheet1 là 180316 sẽ cập nhật thành 250316,và mã hàng F042 không có trong dữ liệu của sheet1 thì bổ sung thêm vào.
Em Cám Ơn Anh nhiều.

 

[ChanhTQ@]

)(in mời bạn xem hình; Mình vừa chụp lại sau khi chạy macro trên file #1 của bạn.

 

[AutoReply]

Không đúng kết quả mong muốn anh
Ví dụ như mã hàng A041 của sheet1 là 150114 sẽ cập nhật thành 160116
còn C043 của sheet1 là 180316 sẽ cập nhật thành 250316,và mã hàng F042 không có trong dữ liệu của sheet1 thì bổ sung thêm vào.
Em Cám Ơn Anh nhiều.

đây là kết quả sau khi chạy code , không biết kết quả sai ở chỗ nào vậy ?

 

[HocVBAExcel]

)(in mời bạn xem hình; Mình vừa chụp lại sau khi chạy macro trên file #1 của bạn.

Mình đã test lại thì bị trường hợp sau
Nếu vẽ nút CommandButton1 dán code vào thì kết quả không đúng
Nhưng chép vào Module thì kết quá rất đúng
Cám ơn Anh rất nhiều.

 

[HocVBAExcel]

Tìm được các đoạn code trên diễn đàn chỉnh sữa đúng yêu cầu nhưng thiếu phần tô màu dòng nếu có sự cập nhật mới.
Đoạn code như sau:

Private Sub CommandButton1_Click()
Dim Dic As Object, sArr(), Darr(), I As Long, K As Long, Tem As String
Dim Arr(), Rng As Range
Set Dic = CreateObject("Scripting.Dictionary")
'-------------------------------------------------------
With Sheet1
Arr = .Range("B5", .[B65536].End(xlUp)).Resize(, 3).Value
For I = 1 To UBound(Arr, 1)
Set Rng = Sheet2.Range("B:B").Find(Arr(I, 1), , , xlWhole)
If Not Rng Is Nothing Then
        Arr(I, 3) = Rng.Offset(, 2)
           End If
           Next
           .Range("B5").Resize(I - 1, 3) = Arr
End With
'--------------------------------------------------------
With Sheet1
        sArr = .Range(.[B5], .[B5].End(xlDown)).Resize(, 3).Value
        For I = 1 To UBound(sArr, 1)
            Tem = sArr(I, 1) & sArr(I, 2) & sArr(I, 3)
            If Not Dic.exists(Tem) Then
                Dic.Add Tem, Empty
            End If
        Next I
    End With
'--------------------------------------------------------
With Sheet2
    sArr = .Range(.[B5], .[B5].End(xlDown)).Resize(, 3).Value
    ReDim Darr(1 To UBound(sArr, 1), 1 To 3)
    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 1) & sArr(I, 2) & sArr(I, 3)
        If Not Dic.exists(Tem) Then
            K = K + 1
            Dic.Add Tem, Empty
            Darr(K, 1) = sArr(I, 1)
            Darr(K, 2) = sArr(I, 2)
            Darr(K, 3) = sArr(I, 3)
        End If
    Next I
    End With
'--------------------------------------------------------
    With Sheet1
    If K Then
    .[B65536].End(xlUp)(2).Resize(K, 3) = Darr
    Else
      Exit Sub
     End If
End With
End Sub

 

[SA_DQ]

Thú thực với bạn là mình rất dị ứng với cách viết Code như bạn trính dẫn; Bỡi mới xem sơ bộ, nên xin có vài í như sau:

(*). Code bạn tìm được bạn chỉ mới chỉnh sửa fần nào đó, nhưng nếu là mình, thì trước tiên mình sã chỉnh để ngay hàng thẳng lối theo cột. Có dễ đọc mới dễ tiếp cận & hiểu được Code của người khác.

(*) Trong Code xử dụng DIctionary, biến mảng,. . . .
Chuyện này giành cho những người cứng về VBA & giành cho CSDL tương đối lớn hay cần chạy Code cho kết quả nhanh; Tất nhiên để lĩnh hội cái nớ cần có vốn đối ứng về VBA tự bản thân bạn 1 cách tương đối.
Tất nhiên GPE.COM luôn có người giúp bạn, nhưng 1 người giúp bạn từ A đến Z là hiếm, 1 khi bạn gặp trỡ ngại cần giải quyết tức thì.

Mong bạn hiểu í mình là: Liệu cơm mà gắp mắm, bạn nha!

Còn chuyện muốn Code đó tô màu được thì không chắc dễ với bạn để hiểu.

 

[HocVBAExcel]

Thú thực với bạn là mình rất dị ứng với cách viết Code như bạn trính dẫn; Bỡi mới xem sơ bộ, nên xin có vài í như sau:

(*). Code bạn tìm được bạn chỉ mới chỉnh sửa fần nào đó, nhưng nếu là mình, thì trước tiên mình sã chỉnh để ngay hàng thẳng lối theo cột. Có dễ đọc mới dễ tiếp cận & hiểu được Code của người khác.

(*) Trong Code xử dụng DIctionary, biến mảng,. . . .
Chuyện này giành cho những người cứng về VBA & giành cho CSDL tương đối lớn hay cần chạy Code cho kết quả nhanh; Tất nhiên để lĩnh hội cái nớ cần có vốn đối ứng về VBA tự bản thân bạn 1 cách tương đối.
Tất nhiên GPE.COM luôn có người giúp bạn, nhưng 1 người giúp bạn từ A đến Z là hiếm, 1 khi bạn gặp trỡ ngại cần giải quyết tức thì.

Mong bạn hiểu í mình là: Liệu cơm mà gắp mắm, bạn nha!

Còn chuyện muốn Code đó tô màu được thì không chắc dễ với bạn để hiểu.

Cám Ơn HYen17 đã góp ý

 

[HocVBAExcel]

Chào các Anh Chị
Em vừa tìm trên diễn đàn có bài cập nhật dữ liệu ở link sau
http://www.giaiphapexcel.com/forum/...-dữ-liệu-từ-sheet1-sang-sheet2-theo-điều-kiện
Đoạn code này cập dữ liệu mới còn dữ liệu cũ xóa đi vậy em muốn dữ lại nhờ các anh chị hướng dẫn thêm.

Private Sub CommandButton1_Click()
Dim Dic As Object, sArr(), tArr(1 To 1000, 1 To 2), Darr(1 To 1000, 1 To 1)
Dim I As Long, K As Long, C As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
sArr = .Range(.[B5], .[B65536].End(xlUp)).Resize(, 3).Value
End With
For I = 1 To UBound(sArr, 1)
    K = K + 1
    Tem = sArr(I, 1)
    If Not Dic.exists(Tem) Then Dic.Add Tem, K
    tArr(I, 1) = sArr(I, 1)
    tArr(I, 2) = sArr(I, 2)
Next I
'------------------------------------------------------------
With Sheet2
    sArr = .Range(.[B5], .[B65536].End(xlUp)).Resize(, 3).Value
End With
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
   [COLOR=#ff0000] If Dic.exists(Tem) Then
        Darr(Dic.Item(Tem), 1) = sArr(I, 3)[/COLOR]
    Else
        K = K + 1
        tArr(K, 1) = sArr(I, 1)
        tArr(K, 2) = sArr(I, 2)
        Darr(K, 1) = sArr(I, 3)
    End If
Next I
'-------------------------------------------------------------
With Sheet1
.[B5].Resize(K, 2) = tArr
.[D5].Resize(K).Value = Darr
End With
End Sub