Cập nhật dữ liệu từ sheet này sang sheet khác (1 người xem)

Sub InfoUpdate()

      On Error Resume Next
      
      With Application
      
            .ScreenUpdating = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
      
            Dim InfoArr As Variant, UpdateArr As Variant
            Dim newDate  As Date, oldDate As Date
            Dim Upd As Long, Inf As Long, i As Long, n As Long, u As Long
            
            UpdateArr = Range(Sheet1.[A2], Sheet1.[A65536].End(xlUp)).Resize(, 4).Value
            InfoArr = Range(Sheet2.[A2], Sheet2.[A65536].End(xlUp)).Resize(, 3).Value
            
            Upd = UBound(UpdateArr)
            Inf = UBound(InfoArr)
            
            For u = 1 To Upd
                  oldDate = UpdateArr(u, 3): n = 0
                  For i = 1 To Inf
                        newDate = InfoArr(i, 2)
                        If InfoArr(i, 1) = UpdateArr(u, 1) And newDate > oldDate Then
                                    If UpdateArr(u, 2) = "" Then
                                    UpdateArr(u, 2) = "1." & Chr(160) & InfoArr(i, 3)
                              Else
                                    n = 1 + CharCount(UpdateArr(u, 2), "." & Chr(160))
                                    UpdateArr(u, 2) = UpdateArr(u, 2) & vbLf & n & "." & Chr(160) & InfoArr(i, 3)
                              End If
                              
                              UpdateArr(u, 3) = newDate
                              UpdateArr(u, 4) = InfoArr(i, 3)
                        End If
                  Next
            Next
            
            Sheet1.[A2].Resize(Upd, 4).Value = UpdateArr

            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            .ScreenUpdating = True
      End With
      
End Sub