Xin code VBA tự động cập nhật dữ liệu từ sheet này sang sheet khác theo điều kiện

[acwuy666]

Xin chào mọi người, mong mn giúp em với ạ
Em muốn từ các dữ liệu trong sheet detail trích xuất ra các dữ liệu mong muốn theo các trường cho sẵn, cụ thể ở trong file đính kèm ạ Cụ thể em muốn trích xuất dữ liệu trong Detail sang 2 sheet 4 và 5. Còn 2 sheet phía sau là kết quả em nhập tay ạ. Em muốn về sau chỉ cần cập nhật dữ liệu mới bên sheet detail là 2 sheet kia sẽ tự động cập nhật mà không cần nhập tay nữa ạ
Mong mọi người giúp đỡ, em xin cảm ơn ạ. Máy em xài Ex 2007 ạ

 

[HUONGHCKT]

Xin chào mọi người, mong mn giúp em với ạ
Em muốn từ các dữ liệu trong sheet detail trích xuất ra các dữ liệu mong muốn theo các trường cho sẵn, cụ thể ở trong file đính kèm ạ Cụ thể em muốn trích xuất dữ liệu trong Detail sang 2 sheet 4 và 5. Còn 2 sheet phía sau là kết quả em nhập tay ạ. Em muốn về sau chỉ cần cập nhật dữ liệu mới bên sheet detail là 2 sheet kia sẽ tự động cập nhật mà không cần nhập tay nữa ạ
Mong mọi người giúp đỡ, em xin cảm ơn ạ. Máy em xài Ex 2007 ạ

Tôi nghĩ rằng có thể dùng VBA để bắt sữ kiện thay đổi 1 cột nào đó (và cột đó là cột được nhập cuối cùng trong dòng đó), và có thể xảy ra các trường hợp:
1/ nếu đã cập nhật vào sh4 và sh5 rồi nhưng sau đó mới thay đổi dữ liệu ở các cột khác thì 2 sheet 4 và 5 sẽ không được cập nhật lại.
2/ nếu đã cập nhật vào sh4 và sh5 rồi nhưng lại có thay đổi ở cột bắt sự kiện thì Sh4 và sh5 sẽ bị nhập trùng (các ô khác giống nhau, chỉ ô bắt sự kiện đó khác)
Còn để xử lý tình huống này thì chủ thớt tìm hiểu thêm code sự kiện Ô nào đó thay đổi sẽ kéo theo sự thay đổi ô khác ở sheet khác (code này của anh @batman1 ).

 

[acwuy666]

Tôi nghĩ rằng có thể dùng VBA để bắt sữ kiện thay đổi 1 cột nào đó (và cột đó là cột được nhập cuối cùng trong dòng đó), và có thể xảy ra các trường hợp:
1/ nếu đã cập nhật vào sh4 và sh5 rồi nhưng sau đó mới thay đổi dữ liệu ở các cột khác thì 2 sheet 4 và 5 sẽ không được cập nhật lại.
2/ nếu đã cập nhật vào sh4 và sh5 rồi nhưng lại có thay đổi ở cột bắt sự kiện thì Sh4 và sh5 sẽ bị nhập trùng (các ô khác giống nhau, chỉ ô bắt sự kiện đó khác)
Còn để xử lý tình huống này thì chủ thớt tìm hiểu thêm code sự kiện Ô nào đó thay đổi sẽ kéo theo sự thay đổi ô khác ở sheet khác (code này của anh @batman1 ).

Cảm ơn bác đã giúp đỡ ạ, nhưng em mới vô group, em có tìm nhưng không thấy code bác nói, bác có thể giúp em thêm 1 tí nữa được không ạ, cảm ơn bác nhiều ạ

 

[HUONGHCKT]

Cảm ơn bác đã giúp đỡ ạ, nhưng em mới vô group, em có tìm nhưng k thấy code bác nói, bác có thể giúp em thêm 1 tí nữa được không ạ, cảm ơn bác nhiều ạ

Khuyên bạn: Hãy tự rèn luyện mình không nên viết tắt trong mọi tình huống nếu muốn nhận được nhiều sự trợ giúp.
Tham khảo code này của anh @batman nhé.

Option Explicit
'By Batman1

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewValue, OldValue
    Dim i&, iRow&, Col&, Lr&
    Dim Rng As Range, dong&
    Dim Sh As Worksheet, Ws As Worksheet
   Set Sh = Sheets("DaTa")
'       Lr = Sh.Cells(Rows.Count, "B").End(xlUp).Row
      
    Application.ScreenUpdating = False
    Application.EnableEvents = False

If Not Intersect(Target, Sh.Range("A3:J10000")) Is Nothing Then
    NewValue = Target.Value
    iRow = Target.Row: Col = Target.Column
    If Sh.Range("G" & iRow) = "X" Then
        Set Ws = Sheets("Nu")
    Else
        Set Ws = Sheets("Nam")
    End If
    Application.Undo
    OldValue = Target.Value
    MsgBox OldValue
    
    
    Target.Value = NewValue
    MsgBox Target.Value
    Lr = Ws.Cells(Rows.Count, Col).End(xlUp).Row
    Set Rng = Ws.Range(Ws.Cells(2, Col), Ws.Cells(Lr, Col))
    If Not Rng.Find(OldValue) Is Nothing Then
        dong = Rng.Find(OldValue).Row
        
 '   Ws.Range(Ws.Cells(2, Col), Ws.Cells(Lr, Col)).Replace What:=OldValue, Replacement:=NewValue, _
       LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True
Ws.Cells(dong, Col) = NewValue '.Replace What:=OldValue, Replacement:=NewValue, _
       LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True
    Else
        MsgBox "không có"
    End If
End If
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
MsgBox "Done"
End Sub

 

[acwuy666]

Khuyên bạn: Hãy tự rèn luyện mình không nên viết tắt trong mọi tình huống nếu muốn nhận được nhiều sự trợ giúp.
Tham khảo code này của anh @batman nhé.

Option Explicit
'By Batman1

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewValue, OldValue
    Dim i&, iRow&, Col&, Lr&
    Dim Rng As Range, dong&
    Dim Sh As Worksheet, Ws As Worksheet
   Set Sh = Sheets("DaTa")
'       Lr = Sh.Cells(Rows.Count, "B").End(xlUp).Row
     
    Application.ScreenUpdating = False
    Application.EnableEvents = False

If Not Intersect(Target, Sh.Range("A3:J10000")) Is Nothing Then
    NewValue = Target.Value
    iRow = Target.Row: Col = Target.Column
    If Sh.Range("G" & iRow) = "X" Then
        Set Ws = Sheets("Nu")
    Else
        Set Ws = Sheets("Nam")
    End If
    Application.Undo
    OldValue = Target.Value
    MsgBox OldValue
   
   
    Target.Value = NewValue
    MsgBox Target.Value
    Lr = Ws.Cells(Rows.Count, Col).End(xlUp).Row
    Set Rng = Ws.Range(Ws.Cells(2, Col), Ws.Cells(Lr, Col))
    If Not Rng.Find(OldValue) Is Nothing Then
        dong = Rng.Find(OldValue).Row
       
 '   Ws.Range(Ws.Cells(2, Col), Ws.Cells(Lr, Col)).Replace What:=OldValue, Replacement:=NewValue, _
       LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True
Ws.Cells(dong, Col) = NewValue '.Replace What:=OldValue, Replacement:=NewValue, _
       LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True
    Else
        MsgBox "không có"
    End If
End If
   
    Application.ScreenUpdating = True
    Application.EnableEvents = True
MsgBox "Done"
End Sub

Dạ em cảm ơn bác đã giúp đỡ nhiệt tình ạ, em sẽ rút kinh nghiệm không ghi tắt vào lần sau ạ

 

[BuiQuangThuan]

Dạ em cảm ơn bác đã giúp đỡ nhiệt tình ạ, em sẽ rút kinh nghiệm không ghi tắt vào lần sau ạ

Thử code sau với file trên coi.

Option Explicit
Sub TONGHOP()
    Dim Dic As Object, sArr(), sRes(), Res(), i&, iRow&, Key, S, k&
    Dim dayNames(7) As String
    dayNames(1) = "Ch" & ChrW(7911) & " Nh" & ChrW(7853) & "t"
    dayNames(2) = "Th" & ChrW(7913) & " Hai"
    dayNames(3) = "Th" & ChrW(7913) & " Ba"
    dayNames(4) = "Th" & ChrW(7913) & " T" & ChrW(432)
    dayNames(5) = "Th" & ChrW(7913) & " N" & ChrW(259) & "m"
    dayNames(6) = "Th" & ChrW(7913) & " S" & ChrW(225) & "u"
    dayNames(7) = "Th" & ChrW(7913) & " B" & ChrW(7843) & "y"
    Application.ScreenUpdating = False
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    Dic.Add "TM", 4: Dic.Add "CK", 5: Dic.Add "VNPAY", 6: Dic.Add "TH" & ChrW(7866), 7: Dic.Add "VO", 8
    With Sheets("Detail")
        iRow = .Range("E" & .Rows.Count).End(xlUp).Row
        If iRow < 3 Then
            MsgBox "Không có du lieu"
            Exit Sub
        End If
        sArr = .Range("A3:S" & iRow).Value
    End With
    ReDim sRes(1 To UBound(sArr), 1 To 10)
    ReDim Res(1 To UBound(sArr), 1 To 12)
    For i = 1 To UBound(sArr)
        Key = Join(Array(sArr(i, 3), sArr(i, 5), sArr(i, 8), sArr(i, 6)), "|")
        If Key <> "|||" Then
            Dic(Key) = Dic(Key) + sArr(i, 14)
        End If
    Next
    For Each Key In Dic.keys
        S = Split(Key, "|")
        If UBound(S) >= 3 Then
            k = k + 1
            sRes(k, 1) = dayNames(Weekday(CDate(S(1))))
            sRes(k, 2) = CDate(S(1))
            sRes(k, 3) = S(2)
            sRes(k, 4) = "TH"
            sRes(k, 6) = Dic(Key)
            sRes(k, 9) = S(0)
            sRes(k, 10) = sRes(k, 6) + sRes(k, 7)
            Res(k, 1) = sRes(k, 1)
            Res(k, 2) = sRes(k, 2)
            Res(k, 3) = sRes(k, 3)
            If Dic.Exists(S(3)) Then
                Res(k, Dic(S(3))) = Dic(Key)
            End If
            Res(k, 10) = S(0)
            Res(k, 11) = "TH"
            Res(k, 12) = WorksheetFunction.Sum(Res(k, 4), Res(k, 5), Res(k, 6), Res(k, 7), Res(k, 8), -Res(k, 9))
        End If
    Next
    With Sheets("REVENUE DAILY REPORT")
        If k Then
            .Range("A13").Resize(10000, 10).ClearContents
            .Range("A13").Resize(k, 10).Value = sRes
            .Range("A13").Resize(k, 10).Sort .Range("B12"), xlAscending
        End If
    End With
    With Sheets("CASH DAILY REPORT")
        If k Then
            .Range("A14").Resize(10000, 12).ClearContents
            .Range("A14").Resize(k, 12).Value = Res
            .Range("A14").Resize(k, 12).Sort .Range("B13"), xlAscending
        End If
    End With
    Application.ScreenUpdating = True
    MsgBox "Ðã hoàn thành", vbOKOnly, "Thông báo"
End Sub