Lấy dữ liệu mới không trùng với dữ liệu đã có và đổ vào sheet khác (1 người xem)

  • Thread starter Thread starter thufpts
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

thufpts

Thành viên hoạt động
Tham gia
6/8/12
Bài viết
157
Được thích
6
Giới tính
Nam
Nghề nghiệp
Bốc vác
Dear các Bác.
em có vấn đề này mong các bác cứu giúp.
em có một file excel bao gồm 3 Sheet CONTROLLER, DATA, NEW
bây giờ em muốn lấy ra dữ liệu của của DATA không được trùng với CONTROLLER với điều kiện cột K chỉ lấy 01, và 02 và đổ vào sheet NEW.
tại sheet NEW em đã đặt sẵn các cột cần lấy của sheet DATA( từ A đến R)

Dữ liệu của sheet DATA và CONTROLLER có Cột A làm khóa chính để các bác tiện so sánh.
em không rành về vba lắm rất mong các bác giúp đỡ
 

File đính kèm

Dear Bác HieuCD em không biết cám ơn bác như thế nào cho đủ. nếu em không có những người như bác thì em mãi là nông dân quèn.
trân trọng cám ơn bác.
"Nông dân" mà gõ được tiếng Việt và mần Code VBA, là "Trí thức - VIỆT", không phải trí thức ngoại lai.
"Nông dân" mà gõ được tiếng Việt PHA TẠP lẫn tiếng Anh, chắc là "Nông dân...".

Ậy dà, cái "nữa nạc nữa mỡ" này không biết định nghĩa anh VetMini ơi! }}}}}}}}}}}}}}} khà khà khà.

Chúc anh em một ngày thiệt vui tươi.
 
Upvote 0
chạy lần 1 nó copy cả 2 sheet bình thường
chạy lần 2 sheet CONTROLLER có thêm dữ liệu, nên dữ liệu sheet DATA không thỏa điều kiện và báo lổi
code thêm phần bẩy lổi, và chỉnh lại tăng tốc độ
Mã:
Sub GPE()
Dim Drng As Range, sArr(), Dic As Object, i As Long, R As Long, LastR As Long, Rng As Range
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
R = Sheets("DATA").Range("A65500").End(xlUp).Row
Set Drng = Sheets("DATA").Range("A2:R" & R)
LastR = Sheets("CONTROLLER").Range("A65500").End(xlUp).Row
sArr = Sheets("CONTROLLER").Range("A2:A" & LastR).Value
For i = 1 To UBound(sArr)
  If Not Dic.exists(sArr(i, 1)) Then Dic.Add (sArr(i, 1)), ""
Next i
For i = 1 To R - 1
  If Not Dic.exists(Drng(i, 1).Value) And (Drng(i, 11) = "01" Or Drng(i, 11) = "02") Then
    k = k + 1
    If Rng Is Nothing Then
      Set Rng = Range(Drng(i, 1), Drng(i, 18))
    Else
      Set Rng = Application.Union(Rng, Range(Drng(i, 1), Drng(i, 18)))
    End If
  End If
Next i
Sheets("NEW").Range("A2:R20000").ClearContents
If Not Rng Is Nothing Then
  Rng.Copy Sheets("NEW").Range("A2")
  Rng.Copy Sheets("CONTROLLER").Range("A" & LastR + 1)
Else
  MsgBox ("Khong tim thay du lieu thoa dieu kien")
End If
Application.ScreenUpdating = True
End Sub
Dear Bác HieuCD.
em gặp phải lỗi này.khi em nhấn button GPE tại sheet NEW lần 1 thì ok nhưng lần 2 nó bị mất định dang. ví dụ Cột I của Sheet CONTROLLER cứ có số 0 đằng trước là bị mất.
07959 thành 7959.
Vấn đề 2 là em có một file access em thực hiện query từ access ra excel nhưng mà nó quay mãi mất cả tiếng mới ra kết quả.
em đã tìm hiểu trên diễn đàn về các làm vba nhưng thực sự là nó quá khó so với em. bác giúp em với
file đính kèm em gửi để bác dễ check.
 

File đính kèm

Upvote 0
Dear Bác HieuCD.
em gặp phải lỗi này.khi em nhấn button GPE tại sheet NEW lần 1 thì ok nhưng lần 2 nó bị mất định dang. ví dụ Cột I của Sheet CONTROLLER cứ có số 0 đằng trước là bị mất.
07959 thành 7959.
Vấn đề 2 là em có một file access em thực hiện query từ access ra excel nhưng mà nó quay mãi mất cả tiếng mới ra kết quả.
em đã tìm hiểu trên diễn đàn về các làm vba nhưng thực sự là nó quá khó so với em. bác giúp em với
file đính kèm em gửi để bác dễ check.
do excel tự định dạng lại, bạn định dang cột I theo Text
Sub GPE()
Dim Drng As Range, sArr(), Dic As Object, i As Long, R As Long, LastR As Long, Rng As Range
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
R = Sheets("DATA").Range("A65500").End(xlUp).Row
Set Drng = Sheets("DATA").Range("A2:R" & R)
LastR = Sheets("CONTROLLER").Range("A65500").End(xlUp).Row
sArr = Sheets("CONTROLLER").Range("A2:A" & LastR).Value
For i = 1 To UBound(sArr)
If Not Dic.exists(sArr(i, 1)) Then Dic.Add (sArr(i, 1)), ""
Next i
For i = 1 To R - 1
If Not Dic.exists(Drng(i, 1).Value) And (Drng(i, 11) = "01" Or Drng(i, 11) = "02") Then
k = k + 1
If Rng Is Nothing Then
Set Rng = Range(Drng(i, 1), Drng(i, 18))
Else
Set Rng = Application.Union(Rng, Range(Drng(i, 1), Drng(i, 18)))
End If
End If
Next i
Sheets("NEW").Range("A2:R20000").ClearContents
Sheets("CONTROLLER").Range("I2").Resize(LastR).NumberFormat = "@"
If Not Rng Is Nothing Then
Rng.Copy Sheets("NEW").Range("A2")
Rng.Copy Sheets("CONTROLLER").Range("A" & LastR + 1)
Else
MsgBox ("Khong tim thay du lieu thoa dieu kien")
End If
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
do excel tự định dạng lại, bạn định dang cột I theo Text
Sub GPE()
Dim DR As Range, Rng As Range, Sarr(), Dic As Object, DicD As Object
Dim i As Long, R As Long, LastR As Long, Tmp As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set DicD = CreateObject("Scripting.Dictionary")
R = Sheets("DATA").Range("A65500").End(xlUp).Row
Set DR = Sheets("DATA").Range("A2:R" & R)
LastR = Sheets("CONTROLLER").Range("A65500").End(xlUp).Row
Sarr = Sheets("CONTROLLER").Range("A2:M" & LastR).Value
For i = 1 To UBound(Sarr)
Tmp = Sarr(i, 1)
If Not Dic.exists(Tmp) Then Dic.Add (Tmp), ""
Next i
For i = 1 To R - 1
Tmp = DR(i, 1).Value
If Not Dic.exists(Tmp) Then
If DR(i, 11) = "02" Then
k = k + 1
If Rng Is Nothing Then
Set Rng = Range(DR(i, 1), DR(i, 18))
Else
Set Rng = Application.Union(Rng, Range(DR(i, 1), DR(i, 18)))
End If
End If
Else
If Not DicD.exists(Tmp) Then DicD.Add (Tmp), _
Array(DR(i, 10).Value, DR(i, 11).Value, DR(i, 12).Value, DR(i, 13).Value)
End If
Next i
Dim Var As Variant
For i = 1 To UBound(Sarr)
If DicD.exists(Sarr(i, 1)) Then
Var = DicD.Item(Sarr(i, 1))
If Sarr(i, 11) < 95 Then
Sarr(i, 11) = Format(Var(1), "@@")
End If
If Sarr(i, 11) < 35 Then
Sarr(i, 10) = Var(0)
Sarr(i, 12) = Var(2)
Sarr(i, 13) = Var(3)
End If
End If
Next i
Sheets("CONTROLLER").Range("K2").Resize(LastR - 1).NumberFormat = "@"
Sheets("CONTROLLER").Range("A2").Resize(LastR - 1, 13) = Sarr
If Not Rng Is Nothing Then
Sheets("NEW").Range("A2:R20000").ClearContents
Sheets("CONTROLLER").Range("I2").Resize(LastR).NumberFormat = "@"
Rng.Copy Sheets("NEW").Range("A2")
Rng.Copy Sheets("CONTROLLER").Range("A" & LastR + 1)
Else
MsgBox ("Updated")
End If
Application.ScreenUpdating = True
End Sub
Nó vẫn không được bác ạ
 
Upvote 0
mình có chỉnh lại ở bài #23, nhưng bạn copy code lẹ quá, xem lại bài 23
Sory bác. lỗi do em copy nhầm em không để ý. đúng ra là em đinh hỏi bác code ở bài 24 nhưng trước đó em lại copy nhầm ở bài khác.
em thêm code dòng màu đỏ vào bài 24 nó vẫn không chạy được. bác fix giúp em với.
cả vấn đề 2 trong file zip đính kèm nữa nếu bác rảnh.
 
Upvote 0
Sory bác. lỗi do em copy nhầm em không để ý. đúng ra là em đinh hỏi bác code ở bài 24 nhưng trước đó em lại copy nhầm ở bài khác.
em thêm code dòng màu đỏ vào bài 24 nó vẫn không chạy được. bác fix giúp em với.
cả vấn đề 2 trong file zip đính kèm nữa nếu bác rảnh.
bạn thêm định dạng Text cột I
Mã:
Sub GPE()
Dim DR As Range, Rng As Range, Sarr(), Dic As Object, DicD As Object
Dim i   As Long, R As Long, LastR As Long, Tmp As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set DicD = CreateObject("Scripting.Dictionary")
R = Sheets("DATA").Range("A65500").End(xlUp).Row
Set DR = Sheets("DATA").Range("A2:R" & R)
LastR = Sheets("CONTROLLER").Range("A65500").End(xlUp).Row
Sarr = Sheets("CONTROLLER").Range("A2:M" & LastR).Value
For i = 1 To UBound(Sarr)
  Tmp = Sarr(i, 1)
  If Not Dic.exists(Tmp) Then Dic.Add (Tmp), ""
Next i
For i = 1 To R - 1
  Tmp = DR(i, 1).Value
  If Not Dic.exists(Tmp) Then
    If DR(i, 11) = "02" Then
      k = k + 1
      If Rng Is Nothing Then
        Set Rng = Range(DR(i, 1), DR(i, 18))
      Else
        Set Rng = Application.Union(Rng, Range(DR(i, 1), DR(i, 18)))
      End If
    End If
  Else
    If Not DicD.exists(Tmp) Then DicD.Add (Tmp), _
        Array(DR(i, 10).Value, DR(i, 11).Value, DR(i, 12).Value, DR(i, 13).Value)
  End If
Next i
Dim Var As Variant
For i = 1 To UBound(Sarr)
  If DicD.exists(Sarr(i, 1)) Then
    Var = DicD.Item(Sarr(i, 1))
    If Sarr(i, 11) < 95 Then
      Sarr(i, 11) = Format(Var(1), "@@")
    End If
    If Sarr(i, 11) < 35 Then
      Sarr(i, 10) = Var(0)
      Sarr(i, 12) = Var(2)
      Sarr(i, 13) = Var(3)
    End If
  End If
Next i
[COLOR=#ff0000]Sheets("CONTROLLER").Range("I2").Resize(LastR - 1).NumberFormat = "@"[/COLOR]
Sheets("CONTROLLER").Range("K2").Resize(LastR - 1).NumberFormat = "@"
Sheets("CONTROLLER").Range("A2").Resize(LastR - 1, 13) = Sarr
If Not Rng Is Nothing Then
  Sheets("NEW").Range("A2:R20000").ClearContents
  Rng.Copy Sheets("NEW").Range("A2")
  Rng.Copy Sheets("CONTROLLER").Range("A" & LastR + 1)
Else
  MsgBox ("Updated")
End If
Application.ScreenUpdating = True
End Sub
còn access mình ít làm, mình chỉ có thể viết SQL để trích dữ liệu trong Query, bạn nêu yêu cầu tuần sau rảnh mình sẽ thử viết xem được không
 
Upvote 0
còn access mình ít làm, mình chỉ có thể viết SQL để trích dữ liệu trong Query, bạn nêu yêu cầu tuần sau rảnh mình sẽ thử viết xem được không
Vâng bác rảnh thì được thì bác giúp em thôi. còn code format đã ok rồi bác ạ. cám ơn bác.
 
Upvote 0
bạn thêm định dạng Text cột I
Mã:
Sub GPE()
Dim DR As Range, Rng As Range, Sarr(), Dic As Object, DicD As Object
Dim i   As Long, R As Long, LastR As Long, Tmp As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set DicD = CreateObject("Scripting.Dictionary")
R = Sheets("DATA").Range("A65500").End(xlUp).Row
Set DR = Sheets("DATA").Range("A2:R" & R)
LastR = Sheets("CONTROLLER").Range("A65500").End(xlUp).Row
Sarr = Sheets("CONTROLLER").Range("A2:M" & LastR).Value
For i = 1 To UBound(Sarr)
  Tmp = Sarr(i, 1)
  If Not Dic.exists(Tmp) Then Dic.Add (Tmp), ""
Next i
For i = 1 To R - 1
  Tmp = DR(i, 1).Value
  If Not Dic.exists(Tmp) Then
    If DR(i, 11) = "02" Then
      k = k + 1
      If Rng Is Nothing Then
        Set Rng = Range(DR(i, 1), DR(i, 18))
      Else
        Set Rng = Application.Union(Rng, Range(DR(i, 1), DR(i, 18)))
      End If
    End If
  Else
    If Not DicD.exists(Tmp) Then DicD.Add (Tmp), _
        Array(DR(i, 10).Value, DR(i, 11).Value, DR(i, 12).Value, DR(i, 13).Value)
  End If
Next i
Dim Var As Variant
For i = 1 To UBound(Sarr)
  If DicD.exists(Sarr(i, 1)) Then
    Var = DicD.Item(Sarr(i, 1))
    If Sarr(i, 11) < 95 Then
      Sarr(i, 11) = Format(Var(1), "@@")
    End If
    If Sarr(i, 11) < 35 Then
      Sarr(i, 10) = Var(0)
      Sarr(i, 12) = Var(2)
      Sarr(i, 13) = Var(3)
    End If
  End If
Next i
[COLOR=#ff0000]Sheets("CONTROLLER").Range("I2").Resize(LastR - 1).NumberFormat = "@"[/COLOR]
Sheets("CONTROLLER").Range("K2").Resize(LastR - 1).NumberFormat = "@"
Sheets("CONTROLLER").Range("A2").Resize(LastR - 1, 13) = Sarr
If Not Rng Is Nothing Then
  Sheets("NEW").Range("A2:R20000").ClearContents
  Rng.Copy Sheets("NEW").Range("A2")
  Rng.Copy Sheets("CONTROLLER").Range("A" & LastR + 1)
Else
  MsgBox ("Updated")
End If
Application.ScreenUpdating = True
End Sub
còn access mình ít làm, mình chỉ có thể viết SQL để trích dữ liệu trong Query, bạn nêu yêu cầu tuần sau rảnh mình sẽ thử viết xem được không
Bác HieuCD ơi bác chỉnh giúp em thêm điều kiện với. nghĩa là khi cả 2 SKU tồn tại đồng thời ở cả sheet DATA và CONTROLLER tại cột A.
Nếu như SKU tại DATA có STATUS < 35 mà bị mất đi thì SKU tương ứng bên CONTROLLER cũng bị mất đi.
bác giúp em với em loay hoay mãi vì nó nhiều dữ liệu rất dễ nhầm.
 
Upvote 0
Bác HieuCD ơi bác chỉnh giúp em thêm điều kiện với. nghĩa là khi cả 2 SKU tồn tại đồng thời ở cả sheet DATA và CONTROLLER tại cột A.
Nếu như SKU tại DATA có STATUS < 35 mà bị mất đi thì SKU tương ứng bên CONTROLLER cũng bị mất đi.
bác giúp em với em loay hoay mãi vì nó nhiều dữ liệu rất dễ nhầm.
bạn chạy code sau, chạy hơi chậm
Mã:
Sub DelCONTROL()
Dim Darr(), Sarr(), Dic As Object, i As Long, Tmp As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
  Darr = .Range("A2:K" & .Range("A65500").End(xlUp).Row).Value
End With
For i = 1 To UBound(Darr)
  If Darr(i, 11) < 35 Then
    Tmp = Darr(i, 1)
    If Not Dic.exists(Tmp) Then Dic.Add (Tmp), ""
  End If
Next i
With Sheets("CONTROLLER")
  Sarr = .Range("A1:A" & .Range("A65500").End(xlUp).Row).Value
  For i = 2 To UBound(Sarr)
    Tmp = Sarr(i, 1)
    If Not Dic.exists(Darr(i, 1)) Then
      .Range("A" & i).EntireRow.Delete
    End If
  Next i
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
 
Upvote 0
bạn chạy code sau, chạy hơi chậm
Mã:
Sub DelCONTROL()
Dim Darr(), Sarr(), Dic As Object, i As Long, Tmp As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
  Darr = .Range("A2:K" & .Range("A65500").End(xlUp).Row).Value
End With
For i = 1 To UBound(Darr)
  If Darr(i, 11) < 35 Then
    Tmp = Darr(i, 1)
    If Not Dic.exists(Tmp) Then Dic.Add (Tmp), ""
  End If
Next i
With Sheets("CONTROLLER")
  Sarr = .Range("A1:A" & .Range("A65500").End(xlUp).Row).Value
  For i = 2 To UBound(Sarr)
    Tmp = Sarr(i, 1)
    If Not Dic.exists(Darr(i, 1)) Then
      .Range("A" & i).EntireRow.Delete
    End If
  Next i
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
Em chạy khoảng 2 đến 3 phút nhưng xong rồi nó vẫn còn nguyên bác ạ. bác check giúp em với. nếu có thể bác ghép luôn vào sub GPE trước đó
để không phải tạo 2 button sub.
cám ơn bác
 
Upvote 0
Em chạy khoảng 2 đến 3 phút nhưng xong rồi nó vẫn còn nguyên bác ạ. bác check giúp em với. nếu có thể bác ghép luôn vào sub GPE trước đó
để không phải tạo 2 button sub.
cám ơn bác
để 2 sub để dể quản lý, và sub chính gọn hơn, bạn có thể dùng lệnh: call DelCONTROL đặt ở đầu hoạc cuối sub chính để chạy lệnh xóa
đã sửa lại code, nhanh hơn 1 chút
Mã:
Sub DelCONTROL()
Dim Darr(), Sarr(), Dic As Object, Rng As Range, i As Long, Tmp As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
  Darr = .Range("A2:K" & .Range("A65500").End(xlUp).Row).Value
End With
For i = 1 To UBound(Darr)
  If Darr(i, 11) < 35 Then
    If Not Dic.exists(Darr(i, 1)) Then Dic.Add (Darr(i, 1)), ""
  End If
Next i
With Sheets("CONTROLLER")
  Sarr = .Range("A1:A" & .Range("A65500").End(xlUp).Row).Value
  For i = 2 To UBound(Sarr)
    If Not Dic.exists(Sarr(i, 1)) Then
      If Rng Is Nothing Then
        Set Rng = .Range("A" & i)
      Else
        Set Rng = Application.Union(Rng, .Range("A" & i))
      End If
    End If
  Next i
  If Not Rng Is Nothing Then
    Rng.EntireRow.Delete
  End If
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
nếu quá chậm, thì bỏ hết code và viết lại toàn bộ
 
Upvote 0
để 2 sub để dể quản lý, và sub chính gọn hơn, bạn có thể dùng lệnh: call DelCONTROL đặt ở đầu hoạc cuối sub chính để chạy lệnh xóa
đã sửa lại code, nhanh hơn 1 chút
Mã:
nếu quá chậm, thì bỏ hết code và viết lại toàn bộ[/QUOTE]
cám ơn bác mấy ngày qua chỗ em mất mạng chưa online được. em chạy nếu có vấn đề gì bác support giúp.
 
Upvote 0
để 2 sub để dể quản lý, và sub chính gọn hơn, bạn có thể dùng lệnh: call DelCONTROL đặt ở đầu hoạc cuối sub chính để chạy lệnh xóa
đã sửa lại code, nhanh hơn 1 chút
nếu quá chậm, thì bỏ hết code và viết lại toàn bộ
Bac HieuCD ơi có chút vấn đề. em chỉ muốn loại những SKU có STT <35 có tại CONTROLLER mà không tồn tại ở sheet DATA thôi và phải giữ nguyên các SKU khác.
vì em bấm button dele nó chỉ giữ lại <35 còn các SKU khác có STATUS > 35 nó xóa sạch. bác fix giúp em với.
 
Upvote 0
Bac HieuCD ơi có chút vấn đề. em chỉ muốn loại những SKU có STT <35 có tại CONTROLLER mà không tồn tại ở sheet DATA thôi và phải giữ nguyên các SKU khác.
vì em bấm button dele nó chỉ giữ lại <35 còn các SKU khác có STATUS > 35 nó xóa sạch. bác fix giúp em với.
mấy hôm nay bận nên không lên diễn đàn. bạn chạy code và kiểm tra lại
Mã:
Sub DelCONTROL()
Dim Darr(), Sarr(), Dic As Object, Rng As Range, i As Long, Tmp As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
  Darr = .Range("A2:K" & .Range("A65500").End(xlUp).Row).Value
End With
For i = 1 To UBound(Darr)
  If Not Dic.exists(Darr(i, 1)) Then Dic.Add (Darr(i, 1)), ""
Next i
With Sheets("CONTROLLER")
  Sarr = .Range("A1:K" & .Range("A65500").End(xlUp).Row).Value
  For i = 2 To UBound(Sarr)
    If  Sarr(i, 11) < 35 Then
      If Not Dic.exists(Sarr(i, 1)) Then
        If Rng Is Nothing Then
          Set Rng = .Range("A" & i)
        Else
          Set Rng = Application.Union(Rng, .Range("A" & i))
        End If
      End If
    End If
  Next i
  If Not Rng Is Nothing Then
    Rng.EntireRow.Delete
  End If
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
 
Upvote 0
mấy hôm nay bận nên không lên diễn đàn. bạn chạy code và kiểm tra lại
Mã:
Sub DelCONTROL()
Dim Darr(), Sarr(), Dic As Object, Rng As Range, i As Long, Tmp As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
  Darr = .Range("A2:K" & .Range("A65500").End(xlUp).Row).Value
End With
For i = 1 To UBound(Darr)
  If Not Dic.exists(Darr(i, 1)) Then Dic.Add (Darr(i, 1)), ""
Next i
With Sheets("CONTROLLER")
  Sarr = .Range("A1:K" & .Range("A65500").End(xlUp).Row).Value
  For i = 2 To UBound(Sarr)
    If  Sarr(i, 11) < 35 Then
      If Not Dic.exists(Sarr(i, 1)) Then
        If Rng Is Nothing Then
          Set Rng = .Range("A" & i)
        Else
          Set Rng = Application.Union(Rng, .Range("A" & i))
        End If
      End If
    End If
  Next i
  If Not Rng Is Nothing Then
    Rng.EntireRow.Delete
  End If
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
Dear bác HieuCD em sory em trả lời muộn em vào link diễn đàn cứ báo NotFound Error 404. mãi giờ mới được
Code dele đã ok rồi bác ạ.
Nhưng em gặp phải vấn đề sub GPE khi em sửa code thêm cột cần cập nhật từ DATA cho sheet CONTROLLER nó không chạy được.
Em thấy code cập nhật các cột theo DATA của bác rất hay em rất muốn triển khai thêm cho sheet khác
trong file đính kèm em có thêm 1 sheet UX, em muốn các cột STUVW tại CONTROLLER cập nhật theo MNOPQ tại sheet UX
và giữ nguyên CONTROLLER khi dữ liệu UX bị mất. em đã thử copy code của bác ra file khác để thực hành nhưng
em bị vướng em không hiểu gì về cấu trúc vòng lặp cả. Rất mong bác giúp em.
 

File đính kèm

Upvote 0
Dear bác HieuCD em sory em trả lời muộn em vào link diễn đàn cứ báo NotFound Error 404. mãi giờ mới được
Code dele đã ok rồi bác ạ.
Nhưng em gặp phải vấn đề sub GPE khi em sửa code thêm cột cần cập nhật từ DATA cho sheet CONTROLLER nó không chạy được.
Em thấy code cập nhật các cột theo DATA của bác rất hay em rất muốn triển khai thêm cho sheet khác
trong file đính kèm em có thêm 1 sheet UX, em muốn các cột STUVW tại CONTROLLER cập nhật theo MNOPQ tại sheet UX
và giữ nguyên CONTROLLER khi dữ liệu UX bị mất. em đã thử copy code của bác ra file khác để thực hành nhưng
em bị vướng em không hiểu gì về cấu trúc vòng lặp cả. Rất mong bác giúp em.
xem file nhưng không rỏ bạn muốn làm gì, bạn phải nói rỏ toàn bộ từ đầu từng vấn đề và nếu cần thì cho ví dụ, lúc đó mới hiểu ý bạn được
 
Upvote 0
xem file nhưng không rỏ bạn muốn làm gì, bạn phải nói rỏ toàn bộ từ đầu từng vấn đề và nếu cần thì cho ví dụ, lúc đó mới hiểu ý bạn được
sr bác.
1. Em muốn bác sửa giúp em sub GPE vì nó chỉ lấy được dữ liệu mới khi click lần 1 nhưng click lần 2 nó không cập nhật được hết các cột J,K,M,N từ CONTROLLER theo DATA mà chỉ cập nhật được duy nhất cột K thôi.
2. Em muốn cập nhật dữ liệu từ sheet CONTROLLER với các cột S,T,U,V,W tương ứng theo các cột M,N,O,P,Q của sheet UX và Nếu dữ liệu UX có bị xóa thì sheet CONTROLLER vẫn được giữ nguyên.
em đã tô màu xanh và đỏ các sheet để bác dễ nhìn. các sheet đều có cột SKU để làm khóa chính.
Mong là bác hiểu những gì em viết.

Cám ơn bác rất nhiều
 

File đính kèm

Upvote 0
sr bác.
1. Em muốn bác sửa giúp em sub GPE vì nó chỉ lấy được dữ liệu mới khi click lần 1 nhưng click lần 2 nó không cập nhật được hết các cột J,K,M,N từ CONTROLLER theo DATA mà chỉ cập nhật được duy nhất cột K thôi.
2. Em muốn cập nhật dữ liệu từ sheet CONTROLLER với các cột S,T,U,V,W tương ứng theo các cột M,N,O,P,Q của sheet UX và Nếu dữ liệu UX có bị xóa thì sheet CONTROLLER vẫn được giữ nguyên.
em đã tô màu xanh và đỏ các sheet để bác dễ nhìn. các sheet đều có cột SKU để làm khóa chính.
Mong là bác hiểu những gì em viết.
Cám ơn bác rất nhiều
mình dùng excel 2007, các file excel 2013 trở về sau có sử dụng các định dạng đặc biệt là bị xử hết, nên các màu không thấy gì hết
để tiết kiệm dung lượng gởi lên diễn đàn và dể theo dõi kết quả, bạn tạo file mới lưu lại với đuôi là .xls, copy vài chục dòng và dán vào, trong đó có đủ các ví dụ về các khả năng có thể xảy ra, tô màu phân biệt và nói rỏ yêu cầu, lúc đó mình mới hình dung được hết các vấn đề được
 
Upvote 0
mình dùng excel 2007, các file excel 2013 trở về sau có sử dụng các định dạng đặc biệt là bị xử hết, nên các màu không thấy gì hết
để tiết kiệm dung lượng gởi lên diễn đàn và dể theo dõi kết quả, bạn tạo file mới lưu lại với đuôi là .xls, copy vài chục dòng và dán vào, trong đó có đủ các ví dụ về các khả năng có thể xảy ra, tô màu phân biệt và nói rỏ yêu cầu, lúc đó mình mới hình dung được hết các vấn đề được

Em đã save file như bác nói nhưng mà khi save .xls nó lên đến 7.2MB không load được. nên em chỉ copy ví dụ và thêm comment để bác dễ hình dung.
em rất muốn bác hiểu và hình dung là trong suốt quá trình từ đầu đến giờ bác đã giúp em làm được gần xong rồi
bây giờ chỉ còn việc cập nhật dữ liệu từ sheet này qua sheet khác và không bị mất đi khi dữ liệu tại sheet nguồn bị xóa.
code bác chuyển cho em bình thường vẫn chạy được ở định dạng xlsb. vì trước bác cũng đưa cho em ở định dang xls sau đó em đưa sang xlsb vẫn ok.
chi là lần này em thêm vào code như sau nên nó mới không chạy được, em đã notes màu đỏ code bên dưới.
Sub GPE()Dim DR As Range, Rng As Range, Sarr(), Dic As Object, DicD As Object
Dim i As Long, R As Long, LastR As Long, Tmp As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set DicD = CreateObject("Scripting.Dictionary")
R = Sheets("DATA").Range("A65500").End(xlUp).Row
Set DR = Sheets("DATA").Range("A2:R" & R)
LastR = Sheets("CONTROLLER").Range("A65500").End(xlUp).Row
Sarr = Sheets("CONTROLLER").Range("A2:N" & LastR).Value (em sửa chữ M sang N)
For i = 1 To UBound(Sarr)
Tmp = Sarr(i, 1)
If Not Dic.exists(Tmp) Then Dic.Add (Tmp), ""
Next i
For i = 1 To R - 1
Tmp = DR(i, 1).Value
If Not Dic.exists(Tmp) Then
If DR(i, 11) >= "02" And DR(i, 11) <= "33" Then
k = k + 1
If Rng Is Nothing Then
Set Rng = Range(DR(i, 1), DR(i, 18))
Else
Set Rng = Application.Union(Rng, Range(DR(i, 1), DR(i, 18)))
End If
End If
Else
If Not DicD.exists(Tmp) Then DicD.Add (Tmp), _
Array(DR(i, 10).Value, DR(i, 11).Value, DR(i, 12).Value, DR(i, 13).Value, DR(i, 14).Value) Em Thêm DR(i, 14).Value
End If
Next i
Dim Var As Variant
For i = 1 To UBound(Sarr)
If DicD.exists(Sarr(i, 1)) Then
Var = DicD.Item(Sarr(i, 1))
If Sarr(i, 11) < 95 Then
Sarr(i, 11) = Format(Var(1), "@@")
End If
If Sarr(i, 11) <= 35 Then
Sarr(i, 10) = Var(0)
Sarr(i, 12) = Var(2)
Sarr(i, 13) = Var(3)
Sarr(i, 14) = Var(4) ( em Thêm mới)
End If
End If
Next i
Sheets("CONTROLLER").Range("I2").Resize(LastR - 1).NumberFormat = "@"
Sheets("CONTROLLER").Range("K2").Resize(LastR - 1).NumberFormat = "@"
Sheets("CONTROLLER").Range("A2").Resize(LastR - 1, 13) = Sarr
If Not Rng Is Nothing Then
Sheets("NEW").Range("A2:R20000").ClearContents
Rng.Copy Sheets("NEW").Range("A2")
Rng.Copy Sheets("CONTROLLER").Range("A" & LastR + 1)
Else
MsgBox ("Updated")
End If
Application.ScreenUpdating = True
End Sub
 

File đính kèm

Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom