Xin code thêm dữ liệu theo điều kiện (1 người xem)

[LYSM]

Em chào các anh chị! Nhờ các anh chị giúp đỡ em code so sánh 2 mảng dữ liệu, khi có dữ liệu trùng thì vlookup vào mảng 1 còn không trùng thì dữ liệu từ mảng 2 tự động được thêm vào mảng 1. Các anh chị xem thêm trên file đính kèm ạ. Em cảm ơn nhiều!

 

[Phuocam]

Em chào các anh chị! Nhờ các anh chị giúp đỡ em code so sánh 2 mảng dữ liệu, khi có dữ liệu trùng thì vlookup vào mảng 1 còn không trùng thì dữ liệu từ mảng 2 tự động được thêm vào mảng 1. Các anh chị xem thêm trên file đính kèm ạ. Em cảm ơn nhiều!

Bạn thử code này xem sao:

Public Sub Vlookup_Add()
Dim i As Long, Lr As Long, k As Long, Tam, rng
Lr = Range("A65536").End(xlUp).Row
Tam = Range(("C3"), Range("D65536").End(xlUp))
For i = 1 To UBound(Tam)
If Tam(i, 1) <> "" Then
    Set rng = Range("A2:B" & Lr).Find(Tam(i, 1), , , xlWhole)
    If Not rng Is Nothing Then
      rng.Offset(, 1) = Tam(i, 2)
    Else
      k = k + 1
      Range("A" & Lr + k) = Tam(i, 1)
      Range("B" & Lr + k) = Tam(i, 2)
    End If
End If
Next
End Sub

 

[LYSM]

Bạn thử code này xem sao:

Public Sub Vlookup_Add()
Dim i As Long, Lr As Long, k As Long, Tam, rng
Lr = Range("A65536").End(xlUp).Row
Tam = Range(("C3"), Range("D65536").End(xlUp))
For i = 1 To UBound(Tam)
If Tam(i, 1) <> "" Then
    Set rng = Range("A2:B" & Lr).Find(Tam(i, 1), , , xlWhole)
    If Not rng Is Nothing Then
      rng.Offset(, 1) = Tam(i, 2)
    Else
      k = k + 1
      Range("A" & Lr + k) = Tam(i, 1)
      Range("B" & Lr + k) = Tam(i, 2)
    End If
End If
Next
End Sub

Bác ơi, code thì chuẩn rồi ạ nhưng dữ liệu của em đến 4000 dòng, có cách nào làm cho code chạy "tốc độ" hơn không ạ? Em chạy thử thì được nhưng chạy full data thì lâu quá. Mong bác giúp đỡ

 

[phulien1902]

Bác ơi, code thì chuẩn rồi ạ nhưng dữ liệu của em đến 4000 dòng, có cách nào làm cho code chạy "tốc độ" hơn không ạ? Em chạy thử thì được nhưng chạy full data thì lâu quá. Mong bác giúp đỡ

Bạn thử thêm đoạn Code này vào xem có cải thiện tốc độ thêm không nhé

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
End With
 
‘ Code của bạn
 
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With

 

[LYSM]

Bạn thử thêm đoạn Code này vào xem có cải thiện tốc độ thêm không nhé

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
End With
 
‘ Code của bạn
 
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With

Dạ cũng hơn chút chút nhưng vẫn chậm bác ạ, em nghĩ phải thay đổi code mới nhanh được.

 

[doveandrose]

nếu nói ngay từ đầu là dữ liệu có bao nhiêu dòng thì ng ta mới biết mà liệu code . dữ liệu mà lớn thì đương nhiên ng ta sẽ viết khác. đây cũng là kinh nghiệm để lần sau diễn đạt cho đầy đủ ý hỏi

 

[LYSM]

nếu nói ngay từ đầu là dữ liệu có bao nhiêu dòng thì ng ta mới biết mà liệu code . dữ liệu mà lớn thì đương nhiên ng ta sẽ viết khác. đây cũng là kinh nghiệm để lần sau diễn đạt cho đầy đủ ý hỏi

Vâng, em sẽ rút kinh nghiệm, có một vài lần đưa dữ liệu đầy đủ lên các bác bảo nhiều quá nhìn rối mắt.

 

[huuthang_bd]

Dạ cũng hơn chút chút nhưng vẫn chậm bác ạ, em nghĩ phải thay đổi code mới nhanh được.

Bạn thử code này xem có cải thiện không

Sub Update()
Dim CurD As Range, NewD As Variant, Dic As Object, Rs As Long, Result As Variant, Tmp As Variant
Set CurD = Range([B3], [A65536].End(xlUp))
NewD = Range([D3], [C65536].End(xlUp)).Value
Rs = CurD.Rows.Count
Result = CurD.Resize(Rs + UBound(NewD, 1)).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(NewD, 1)
    Dic.Item(NewD(i, 1)) = NewD(i, 2)
Next
For i = 1 To Rs
    If Dic.Exists(Result(i, 1)) Then
        Result(i, 2) = Dic.Item(Result(i, 1))
        Dic.Remove (Result(i, 1))
    End If
Next
For Each Tmp In Dic.keys
    Rs = Rs + 1
    Result(Rs, 1) = Tmp:    Result(Rs, 2) = Dic.Item(Tmp)
Next
CurD.Resize(Rs).Value = Result
End Sub

 

[LYSM]

Bạn thử code này xem có cải thiện không

Sub Update()
Dim CurD As Range, NewD As Variant, Dic As Object, Rs As Long, Result As Variant, Tmp As Variant
Set CurD = Range([B3], [A65536].End(xlUp))
NewD = Range([D3], [C65536].End(xlUp)).Value
Rs = CurD.Rows.Count
Result = CurD.Resize(Rs + UBound(NewD, 1)).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(NewD, 1)
    Dic.Item(NewD(i, 1)) = NewD(i, 2)
Next
For i = 1 To Rs
    If Dic.Exists(Result(i, 1)) Then
        Result(i, 2) = Dic.Item(Result(i, 1))
        Dic.Remove (Result(i, 1))
    End If
Next
For Each Tmp In Dic.keys
    Rs = Rs + 1
    Result(Rs, 1) = Tmp:    Result(Rs, 2) = Dic.Item(Tmp)
Next
CurD.Resize(Rs).Value = Result
End Sub

Ngon rồi bác ạ, nhưng code của bác không khai báo biến i mà vẫn chạy được, em cho vào file thật phải khai báo thêm i

 

[Let'GâuGâu]

Ngon rồi bác ạ, nhưng code của bác không khai báo biến i mà vẫn chạy được, em cho vào file thật phải khai báo thêm i

thử không dùng dic

Sub Update()
Dim RngA, rngC As Range, Old_arr, New_Arr As Variant, i As Long, k
Set RngA = Range([a3], [a6000].End(3))
Set rngC = Range([C3], [c6000].End(3))
Old_arr = RngA.Resize(60000, 2).Value
New_Arr = rngC.Resize(, 2).Value
lr = RngA.Rows.Count
For i = 1 To UBound(New_Arr)
    k = Application.Match(New_Arr(i, 1), RngA, 0)
    If TypeName(k) <> "Error" Then
        Old_arr(k, 2) = New_Arr(i, 2)
    Else
        lr = lr + 1
        Old_arr(lr, 1) = New_Arr(i, 1)
        Old_arr(lr, 2) = New_Arr(i, 2)
    End If
Next
[a3].Resize(6000, 2).Clear
[a3].Resize(lr, 2) = Old_arr
End Sub

 

[hong1989]

thử không dùng dic

Sub Update()
Dim RngA, rngC As Range, Old_arr, New_Arr As Variant, i As Long, k
Set RngA = Range([a3], [a6000].End(3))
Set rngC = Range([C3], [c6000].End(3))
Old_arr = RngA.Resize(60000, 2).Value
New_Arr = rngC.Resize(, 2).Value
lr = RngA.Rows.Count
For i = 1 To UBound(New_Arr)
    k = Application.Match(New_Arr(i, 1), RngA, 0)
    If TypeName(k) <> "Error" Then
        Old_arr(k, 2) = New_Arr(i, 2)
    Else
        lr = lr + 1
        Old_arr(lr, 1) = New_Arr(i, 1)
        Old_arr(lr, 2) = New_Arr(i, 2)
    End If
Next
[a3].Resize(6000, 2).Clear
[a3].Resize(lr, 2) = Old_arr
End Sub

cho mình hỏi có cách nào copy theo cột không