Lấy dữ liệu sang sheet khác chỉ lấy mã không trùng

[vanlinh_2904]

Chào các Anh/Chị,
Nhờ các anh chị viết giúp em VBA để lấy dữ liệu từ sheet 1 sang sheet 2 với điều kiện chỉ lấy những "mã nhân viên" mà bên sheet 2 chưa có và điền tiếp vào dòng tiếp theo ở bên sheet 2 như file đính kèm. Cảm ơn các anh/chị.

 

[giaiphap]

Chào các Anh/Chị,
Nhờ các anh chị viết giúp em VBA để lấy dữ liệu từ sheet 1 sang sheet 2 với điều kiện chỉ lấy những "mã nhân viên" mà bên sheet 2 chưa có và điền tiếp vào dòng tiếp theo ở bên sheet 2 như file đính kèm. Cảm ơn các anh/chị.

Thêm đoạn code này vào Sheet2 thử xem thế nào?

Private Sub Worksheet_Activate()
    Dim Dic As Object, Arr, Des, Des2, i%, k%
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet2
        Des = .Range("B3:D" & .Range("D10000").End(xlUp).Row).Value
        Arr = Sheet1.Range("B3:F" & Sheet1.Range("F10000").End(xlUp).Row).Value
        ReDim Des2(1 To UBound(Arr, 1), 1 To 3)
        For i = LBound(Des, 1) To UBound(Des, 1)
            If Not Dic.Exists(Des(i, 1)) Then Dic.Add Des(i, 1), Des(i, 1)
        Next i
        k = 0
        For i = LBound(Arr, 1) To UBound(Arr, 1)
            If Arr(i, 1) <> "" Then
                If Not Dic.Exists(Arr(i, 1)) Then
                    Dic.Add Arr(i, 1), Arr(i, 1)
                    k = k + 1
                    Des2(k, 1) = Arr(i, 1)
                    Des2(k, 2) = Arr(i, 2)
                    Des2(k, 3) = Arr(i, 5)
                End If
            End If
        Next i
        If k Then .Range("B" & (.Range("B10000").End(xlUp).Row + 1)).Resize(k, 3) = Des2
    End With
    Set Dic = Nothing
End Sub

 

[bebo021999]

Đặt trong worksheet module nhé (click chuột phải vào tên sheet/View code)
Phải nhập đủ 5 cột thông tin trên sheet1 thì sheet2 mới cập nhật nhé.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&, i&, k&, rng, arr(1 To 10000, 1 To 3)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
If WorksheetFunction.CountA(Range(Cells(Target.Row, 2), Cells(Target.Row, 6))) <> 5 Then Exit Sub
    With Worksheets("Sheet2")
        lr = .Cells(Rows.Count, "B").End(xlUp).Row
        rng = .Range("B4:D" & lr).Value
        For i = 1 To lr - 3
            If Not dic.exists(rng(i, 1)) Then
                k = k + 1
                arr(k, 1) = rng(i, 1): arr(k, 2) = rng(i, 2): arr(k, 3) = rng(i, 3)
                dic.Add rng(i, 1), ""
            End If
        Next
    End With
    With Worksheets("Sheet1")
        lr = .Cells(Rows.Count, "B").End(xlUp).Row
        rng = .Range("B4:F" & lr).Value
        For i = 1 To lr - 3
            If Not dic.exists(rng(i, 1)) And rng(i, 1) <> "" Then
                k = k + 1
                arr(k, 1) = rng(i, 1): arr(k, 2) = rng(i, 2): arr(k, 3) = rng(i, 5)
                dic.Add rng(i, 1), "" 'arr
            End If
        Next
    End With
    With Worksheets("Sheet2")
        .Range("B4:D10000").ClearContents
        .Range("B4").Resize(k, 3).Value = arr
    End With
Set dic = Nothing
End Sub

 

[vanlinh_2904]

Thêm đoạn code này vào Sheet2 thử xem thế nào?

Private Sub Worksheet_Activate()
    Dim Dic As Object, Arr, Des, Des2, i%, k%
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet2
        Des = .Range("B3:D" & .Range("D10000").End(xlUp).Row).Value
        Arr = Sheet1.Range("B3:F" & Sheet1.Range("F10000").End(xlUp).Row).Value
        ReDim Des2(1 To UBound(Arr, 1), 1 To 3)
        For i = LBound(Des, 1) To UBound(Des, 1)
            If Not Dic.Exists(Des(i, 1)) Then Dic.Add Des(i, 1), Des(i, 1)
        Next i
        k = 0
        For i = LBound(Arr, 1) To UBound(Arr, 1)
            If Arr(i, 1) <> "" Then
                If Not Dic.Exists(Arr(i, 1)) Then
                    Dic.Add Arr(i, 1), Arr(i, 1)
                    k = k + 1
                    Des2(k, 1) = Arr(i, 1)
                    Des2(k, 2) = Arr(i, 2)
                    Des2(k, 3) = Arr(i, 5)
                End If
            End If
        Next i
        If k Then .Range("B" & (.Range("B10000").End(xlUp).Row + 1)).Resize(k, 3) = Des2
    End With
    Set Dic = Nothing
End Sub
[/code
[/QUOTE]

Nhờ bạn sửa giúp mình nếu ở sheet 1 có những mã trùng nhau ví dụ như có 3 mã NV05 ở 3 dòng khác nhau, nhưng ở sheet 2 mã NV05 chưa có thì điền cả 3 dòng có mã NV05 ở Sheet 1 qua sheet 2. Cái code bạn đang lấy mã duy nhất ở sheet 1 sang. Cảm ơn bạn nhiều nhé.

 

[SA_DQ]

Đây là 1 cách không tồi:

Sub ChepDuLieu()
 Dim Rng As Range, sRng As Range, Cls As Range
 Dim Rws As Long, W As Integer, Col As Integer
 
 With Sheet2
    Rws = .[B4].CurrentRegion.Rows.Count
    Set Rng = .[B3].Resize(Rws)
 End With
 Sheet1.Select
 Rws = [B3].CurrentRegion.Rows.Count
 ReDim Arr(1 To Rws, 1 To 5)
 For Each Cls In Range([B4], [B4].End(xlDown))
    Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        W = W + 1
        For Col = 0 To 4
            Arr(W, Col + 1) = Cls.Offset(, Col).Value
        Next Col
    End If
 Next Cls
 If W Then
    Sheet2.[B9999].End(xlUp).Offset(1).Resize(W, 5).Value = Arr()
 End If
 MsgBox "Xong Ròi!", , W
End Sub

 

[giaiphap]

Nhờ bạn sửa giúp mình nếu ở sheet 1 có những mã trùng nhau ví dụ như có 3 mã NV05 ở 3 dòng khác nhau, nhưng ở sheet 2 mã NV05 chưa có thì điền cả 3 dòng có mã NV05 ở Sheet 1 qua sheet 2. Cái code bạn đang lấy mã duy nhất ở sheet 1 sang. Cảm ơn bạn nhiều nhé.

Hình như chưa hiểu ý bạn lắm nhưng bạn thử bỏ dòng lệnh này xem có đúng yêu cầu chưa.

Dic.Add Arr(i, 1), Arr(i, 1)

 

[vanlinh_2904]

Hình như chưa hiểu ý bạn lắm nhưng bạn thử bỏ dòng lệnh này xem có đúng yêu cầu chưa.

Dic.Add Arr(i, 1), Arr(i, 1)

Đúng rồi bạn ơi, cảm ơn bạn nhiều nhé.