Code giúp cập nhật dử liệu như hàm VLOOKUP (1 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
H

hong loi

Thành viên hoạt động
Tham gia
11/1/13
Bài viết
104
Được thích
17
Em chào các Thầy! Em có viết code giúp cập nhật dử liệu như hàm VLOOKUP nhưng không thành công, nay em xin các Thầy viết hộ em nhé.

Code chạy theo các tiêu chí sau:

1. Sau khi chỉnh sửa dử liệu cột C,D (TLƯƠNG,HỆ SỐ)ở sheet DANH SACH xong --> click nút --> tự động cập nhật vào các sheet TRUC DEM giống như hàm VLOOKUP (đang có trong file).

2. Khi chỉnh sửa thêm bớt tên ở cột B,G của các sheet TRUC DEM ( thêm tên: có nghĩa là gõ tên từng ô hoặc copy một lược nhiều tên ở sheet DANH SACH past vào) xong --> cột TLƯƠNG,HỆ SỐ tự động cập nhật từ sheet DANH SACH (giống y như hàm VLOOKUP tự cập nhật vậy).

3.Tốc độ code xử lí dử liệu nhanh (điều này cần vì dử liệu thật có nhiều sheet TRUC DEM mổi sheet có 55 dòng, file đính kèm đã cắt nhỏ lại cho tiện gửi file).

Em kính mong các Thầy dành chút thời gian qúi báo giúp em nhé, em rất cám ơn các Thầy.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
hpkhuong đã viết:
Có mỗi bạn không chạy được thôi... Vậy nâng cấp office lên đi chứ đi tìm cái gì mà xa xôi vậy bạn!!!--=0--=0--=0
=> Có thể do bộ office của bạn...!!!
Nhấp chuột vào đây để mở rộng...
Em đã test ở máy khác EXcel 2007 vẫn y chan như vậy, không tìm được nguyên nhân khổ thật.

P/s: file trong bài này không thấy code đó trong file.
Nhấp chuột vào đây để mở rộng...

Em mệt mỏi với cái code của em rồi, em bó tay rồi, em không muốn nó làm khổ em tiếp.
 
Upvote 0
hong loi đã viết:
Em chào các Thầy! Em có viết code giúp cập nhật dử liệu như hàm VLOOKUP nhưng không thành công, nay em xin các Thầy viết hộ em nhé.
Em kính mong các Thầy dành chút thời gian qúi báo giúp em nhé, em rất cám ơn các Thầy.
Nhấp chuột vào đây để mở rộng...

Đã lỡ có bài viết trong Topic này rồi thì trước 12h đêm nay nếu không ai viết code thì tôi viết
mất công có người lập nick là loang_noi_dung vô đây nói tụi tui nói xàm không liên quan đến topic
giờ tui bận
mọi tội lỗi hãy để doveandrose đỡ hết
 
Upvote 0
hpkhuong đã viết:
-------------------------------
Cơ mà có người viết rồi. Nhưng chàng DoveAndRose cũng cho anh em chim ngưỡng đoạn code nhé! Chờ bạn đó...}}}}}}}}}}}}}}}
Nhấp chuột vào đây để mở rộng...

người ta lập topic có đánh số 1 2 3 rõ ràng rồi đó , bạn xem code trên là số mấy ?
ở trên tôi lỡ lời thôi chứ thật ra tôi đâu có biết làm .... bạn xem giúp người ta dùm nhé , cảm ơn . hi hi
 
Upvote 0
hpkhuong đã viết:
Kéo sheet Danh Sách về đầu tiên. Và thử chạy sub này xem
Mã: 
Option Explicit
Sub Vlookup_Nhieu_Sheet()
Dim I&, Kq1(), Kq2(), DL(), Nguon1(), Nguon2()
Dim Itm, Dic As Object, S&, J&, K&
With DanhSach
    DL = .Range(.[B2], .[B65000].End(3)).Resize(, 3)
End With
For S = 2 To Sheets.Count
With Sheets(S)
    Nguon1 = Range(.[B3], .[B65000].End(3))
    Nguon2 = Range(.[G3], .[G65000].End(3))
    ReDim Kq1(1 To UBound(Nguon1), 1 To 2)
    ReDim Kq2(1 To UBound(Nguon2), 1 To 2)
    Set Dic = CreateObject("Scripting.dictionary")
    For I = 1 To UBound(DL)
    Itm = CStr(DL(I, 1))
        If Not Dic.exists(Itm) Then
            Dic.Add CStr(DL(I, 1)), I
        End If
    Next I
    For I = 1 To UBound(Nguon1)
    Itm = CStr(Nguon1(I, 1))
        If Dic.exists(Itm) Then
        For J = 1 To 2
            Kq1(I, J) = DL(Dic.Item(Itm), J + 1)
        Next J
        End If
    Next I
    For K = 1 To UBound(Nguon2)
    Itm = CStr(Nguon2(K, 1))
        If Dic.exists(Itm) Then
        For J = 1 To 2
            Kq2(K, J) = DL(Dic.Item(Itm), J + 1)
        Next J
        End If
    Next K
    .[C3:D65000,H3:I65000].ClearContents
    .[C3].Resize(I - 1, 2) = Kq1
    .[H3].Resize(K - 1, 2) = Kq2
Set Dic = Nothing
End With
Next S
End Sub

Hoặc nếu không kéo sheet Danh Sách về đầu. Mà để bất kỳ ở đâu. Trong file bạn còn có nhiều sheet tương tự TRUC DEM cần cập nhật thì bạn khai báo danh sách tên của các Sheet Cần cập nhật vào Cột O (bắt đầu từ O2, O3,....On) của sheet Danh Sach. Và chạy code sau
Mã: 
Sub Vlookup_NSheet()
Dim I&, Kq1(), Kq2(), DL(), Nguon1(), Nguon2(), Arr
Dim Itm, Dic As Object, S&, J&, K&
With DanhSach
    DL = .Range(.[B2], .[B65000].End(3)).Resize(, 3)
    Arr = .Range(.[O2], .[O2].End(4)).Value
End With
For S = 1 To UBound(Arr)
With Sheets(Arr(S, 1))
    Nguon1 = Range(.[B3], .[B65000].End(3))
    Nguon2 = Range(.[G3], .[G65000].End(3))
    ReDim Kq1(1 To UBound(Nguon1), 1 To 2)
    ReDim Kq2(1 To UBound(Nguon2), 1 To 2)
    Set Dic = CreateObject("Scripting.dictionary")
    For I = 1 To UBound(DL)
    Itm = CStr(DL(I, 1))
        If Not Dic.exists(Itm) Then
            Dic.Add CStr(DL(I, 1)), I
        End If
    Next I
    For I = 1 To UBound(Nguon1)
    Itm = CStr(Nguon1(I, 1))
        If Dic.exists(Itm) Then
        For J = 1 To 2
            Kq1(I, J) = DL(Dic.Item(Itm), J + 1)
        Next J
        End If
    Next I
    For K = 1 To UBound(Nguon2)
    Itm = CStr(Nguon2(K, 1))
        If Dic.exists(Itm) Then
        For J = 1 To 2
            Kq2(K, J) = DL(Dic.Item(Itm), J + 1)
        Next J
        End If
    Next K
    .[C3:D65000,H3:I65000].ClearContents
    .[C3].Resize(I - 1, 2) = Kq1
    .[H3].Resize(K - 1, 2) = Kq2
Set Dic = Nothing
End With
Next S
End Sub

Mỗi lần bạn sửa ở bất kỳ sheet nào mà cần cập nhật lại thì gọi SUB và chạy nó thôi...


Ờ hok biết cái Nick ấy là ai ẩn danh... mà vào nói cả lủ xàm xàm...viết bài không liên quan...kà kà. chắc là anh nào ghen tị với tài chém gió của chúng ta đấy mà...--=0--=0--=0
-------------------------------
Cơ mà có người viết rồi. Nhưng chàng DoveAndRose cũng cho anh em chim ngưỡng đoạn code nhé! Chờ bạn đó...}}}}}}}}}}}}}}}
Nhấp chuột vào đây để mở rộng...

Em cám ơn anh hpkhuong nhiều nhé em thử với file test rồi, code chạy tốt anh ạ. Hiện tại file Excel chính thức của em phát sinh thêm cột, em đang xắp xếp lại cho phù hợp với code của anh để không bị xóa nhầm, nếu còn bị xóa nhầm em nhờ anh chỉnh sửa lại nhé ? (nếu em không tự làm được)

P/S em test với file đầy đủ code chạy không được nhanh rồi anh ơi.
 
Lần chỉnh sửa cuối:
Upvote 0
trời đất quỷ thần ơi , có người viết bài mới mình mới để ý , code của anh ấy có nghĩa là :
cứ mỗi vòng lặp sheet thì lại tạo mới 1 Dictionary =))
có vẻ hc ....
 
Upvote 0
hpkhuong đã viết:
Kaka. Cũng đâu có vấn đề gì nhỉ? Thấy nó chạy là được rồi. Còn mọi chuyện tốn tài nguyên thì để cái máytính nó lo...keke

-------------------
Mà nếu không đưa vào vòng lặp. Tách ra thì như nào, bạn giúp tôi cái. Để học hỏi luôn cái vụ Dic bự Dic bé này...hic hic
Nhấp chuột vào đây để mở rộng...

Thì bạn cứ duyệt qua các item trong sheet danh sách và nạp vào Dic bình thường thôi.
Ý bạn doveandrose là cho Dic ra khỏi vòng lặp duyệt qua các sheet ấy.

Mình thì làm theo cách này, bạn thử tham khảo xem:

Mã: 
Sub MyVlookUp()
   Dim sh As Worksheet
   Dim Dic As Object
   Dim arrDanhSach(), arrTable()
   Dim lngR As Long, lngUbound As Long
   Dim strTmp As String
   With Sheet1
      If .Range("B65000").End(xlUp).Row > 1 Then
         Set Dic = CreateObject("Scripting.Dictionary")
         arrDanhSach = .Range(.Range("B2"), .Range("B65000").End(xlUp)).Resize(, 3).Value2
         For lngR = 1 To UBound(arrDanhSach, 1)
            If Len(arrDanhSach(lngR, 1)) Then
               strTmp = CStr(arrDanhSach(lngR, 1))
               If Not Dic.Exists(strTmp) Then Dic.Add strTmp, Array(arrDanhSach(lngR, 2), arrDanhSach(lngR, 3))
            End If
         Next lngR
      End If
   End With
   If Dic.Count Then
      For Each sh In ThisWorkbook.Worksheets
         With sh
            If .CodeName <> "Sheet1" Then
               lngUbound = IIf(.Range("B65000").End(xlUp).Row > .Range("G65000").End(xlUp).Row, .Range("B65000").End(xlUp).Row, .Range("G65000").End(xlUp).Row)
               arrTable = .Range("B3:I" & lngUbound).Value2
               For lngR = 1 To UBound(arrTable, 1)
                  If Len(arrTable(lngR, 1)) Then
                     strTmp = CStr(arrTable(lngR, 1))
                     If Dic.Exists(strTmp) Then
                        arrTable(lngR, 2) = Dic.Item(strTmp)(0)
                        arrTable(lngR, 3) = Dic.Item(strTmp)(1)
                     End If
                  End If
                  If Len(arrTable(lngR, 6)) Then
                     strTmp = CStr(arrTable(lngR, 6))
                     If Dic.Exists(strTmp) Then
                        arrTable(lngR, 7) = Dic.Item(strTmp)(0)
                        arrTable(lngR, 8) = Dic.Item(strTmp)(1)
                     End If
                  End If
               Next lngR
               .Range("B3").Resize(lngR - 1, 8).Value = arrTable
            End If
         End With
      Next sh
   End If
   'Debug.Print
End Sub

P/S: Mà chẳng hiểu bạn chủ topic này lại tách 1 bảng có cùng cấu trúc thành 2 bảng là có mục đích gì ???
 
Upvote 0
Em muốn khi code chạy gặp những cái tên trong cột HỌ TÊN của các sheet TRUC DEM, nếu tên đó không có trong sheet DANH SACH thì ở cột TLƯƠNG và HỆ SỐ tương ứng với tên đó(trong sheet TRUC DEM) sẻ xóa trống.

Em thêm 2 dòng màu đỏ để đáp ứng ý muốn trên, nhưng sao tốc độ code chạy bị chậm đi rất nhiều. Vậy em nhờ các anh sửa lại code cho phù hợp để tốc độ code vẫn nhanh. Em xin cám ơn.

mhung12005 đã viết:
Mã: 
Sub MyVlookUp()
   Dim sh As Worksheet
   Dim Dic As Object
   Dim arrDanhSach(), arrTable()
   Dim lngR As Long, lngUbound As Long
   Dim strTmp As String
   With DanhSach
      If .Range("B65000").End(xlUp).Row > 1 Then
         Set Dic = CreateObject("Scripting.Dictionary")
         arrDanhSach = .Range(.Range("B2"), .Range("B65000").End(xlUp)).Resize(, 3).Value2
         For lngR = 1 To UBound(arrDanhSach, 1)
            If Len(arrDanhSach(lngR, 1)) Then
               strTmp = CStr(arrDanhSach(lngR, 1))
               If Not Dic.Exists(strTmp) Then Dic.Add strTmp, Array(arrDanhSach(lngR, 2), arrDanhSach(lngR, 3))
            End If
         Next lngR
      End If
   End With
   If Dic.Count Then
      For Each sh In ThisWorkbook.Worksheets
         With sh
            If .CodeName <> "DanhSach" Then
               lngUbound = IIf(.Range("B65000").End(xlUp).Row >  .Range("G65000").End(xlUp).Row, .Range("B65000").End(xlUp).Row,  .Range("G65000").End(xlUp).Row)
                  [COLOR=#ff0000].Range("C3:D" & lngUbound).ClearContents
                  .Range("H3:I" & lngUbound).ClearContents[/COLOR]
               arrTable = .Range("B3:I" & lngUbound).Value2
               For lngR = 1 To UBound(arrTable, 1)
                  If Len(arrTable(lngR, 1)) Then
                     strTmp = CStr(arrTable(lngR, 1))
                     If Dic.Exists(strTmp) Then
                        arrTable(lngR, 2) = Dic.Item(strTmp)(0)
                        arrTable(lngR, 3) = Dic.Item(strTmp)(1)
                     End If
                  End If
                  If Len(arrTable(lngR, 6)) Then
                     strTmp = CStr(arrTable(lngR, 6))
                     If Dic.Exists(strTmp) Then
                        arrTable(lngR, 7) = Dic.Item(strTmp)(0)
                        arrTable(lngR, 8) = Dic.Item(strTmp)(1)
                     End If
                  End If
               Next lngR
               .Range("B3").Resize(lngR - 1, 8).Value = arrTable
            End If
         End With
      Next sh
   End If
   'Debug.Print
End Sub
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
Upvote 0
Em chào các anh.Em xin gửi lại yêu cầu trên diễn đạt theo cách khác.

Khi code quét qua các sheet TRUC DEM, nếu gặp các tên có trong sheet DANH SACH --> dử liệu được cập nhật thành công ở cột TLƯƠNG và HỆ SỐ, nhưng nếu code gặp phải tên không có trong sheet DANH SACH thì nó sẻ bỏ qua luôn phần TLƯƠNG và HỆ SỐ--> không sửa cũng không xóa.

Nay em nhờ các anh sửa code sao cho nếu gặp tên không có trong sheet DANH SACH thì TLƯƠNG và HỆ SỐ phải là ô trống (mụch đích là xóa dử liệu củ TLƯƠNG và HỆ SỐ của tên này).

Rất mong các anh trợ giúp em rất cám ơn.
 
Lần chỉnh sửa cuối:
Upvote 0
Chờ không có ai giúp em tiếp tục thử nghiệm thêm chỗ màu đỏ,tốc độ code đã khôi phục nhưng không biết "chế biến" như vầy có đúng không, em nhờ các Thầy các anh xem giúp và góp ý nhé. Em xin cám ơn.

Mã: 
Sub MyVlookUp()
   Dim sh As Worksheet
   Dim Dic As Object
   Dim arrDanhSach(), arrTable()
   Dim lngR As Long, lngUbound As Long
   Dim strTmp As String
   With DanhSach
      If .Range("B65000").End(xlUp).Row > 1 Then
         Set Dic = CreateObject("Scripting.Dictionary")
         arrDanhSach = .Range(.Range("B2"), .Range("B65000").End(xlUp)).Resize(, 3).Value2
         For lngR = 1 To UBound(arrDanhSach, 1)
            If Len(arrDanhSach(lngR, 1)) Then
               strTmp = CStr(arrDanhSach(lngR, 1))
               If Not Dic.Exists(strTmp) Then Dic.Add strTmp, Array(arrDanhSach(lngR, 2), arrDanhSach(lngR, 3))
            End If
         Next lngR
      End If
   End With
   If Dic.Count Then
      For Each sh In ThisWorkbook.Worksheets
         With sh
            If .CodeName <> "DanhSach" Then
               lngUbound = IIf(.Range("B65000").End(xlUp).Row > .Range("G65000").End(xlUp).Row, .Range("B65000").End(xlUp).Row, .Range("G65000").End(xlUp).Row)
               arrTable = .Range("B3:I" & lngUbound).Value2
               For lngR = 1 To UBound(arrTable, 1)
                  If Len(arrTable(lngR, 1)) Then
                     strTmp = CStr(arrTable(lngR, 1))
                     If Dic.Exists(strTmp) Then
                        arrTable(lngR, 2) = Dic.Item(strTmp)(0)
                        arrTable(lngR, 3) = Dic.Item(strTmp)(1)
                      [COLOR=#ff0000]Else
                        arrTable(lngR, 2) = vbNullString
                        arrTable(lngR, 3) = vbNullString[/COLOR]
                     End If
                  End If
                  If Len(arrTable(lngR, 6)) Then
                     strTmp = CStr(arrTable(lngR, 6))
                     If Dic.Exists(strTmp) Then
                        arrTable(lngR, 7) = Dic.Item(strTmp)(0)
                        arrTable(lngR, 8) = Dic.Item(strTmp)(1)
                     [COLOR=#ff0000]Else
                        arrTable(lngR, 7) = vbNullString
                        arrTable(lngR, 8) = vbNullString
[/COLOR]                     End If
                  End If
               Next lngR
               .Range("B3").Resize(lngR - 1, 8).Value = arrTable
            End If
         End With
      Next sh
   End If
   'Debug.Print
End Sub

p/s em xin ví dụ: Sau khi chạy code của anh mhung12005 vlookup không còn nữa. Ở sheet TRUC DEM nhân viên tên Võ Hoàng Mỹ ( ô B3) hiện đang có TLUONG (ô C3) là 26 và HE SO(ô D3) là 7. Do nghỉ việc nên nhân viên Võ Hoàng Mỹ bị xóa tên ở sheet DANH SACH, lúc này nếu chạy code của anh mhung12005 lần nữa thì TLUONG (ô C3) vẫn là 26 và HE SO(ô D3) vẫn là 7, tức 2 ô này bị bỏ qua.

Nếu thêm phần màu đỏ vào code của anh mhung12005 chạy code lần nữa thì TLUONG (ô C3) và HE SO(ô D3) là ô trống đúng với yêu cầu của em.
 
Lần chỉnh sửa cuối:
Upvote 0
Em thêm phần ví dụ cụ thể để nêu rỏ hơn yêu cầu của em, em xin các Thầy và các anh xem lại.
 
Upvote 0
hong loi đã viết:
Em thêm phần ví dụ cụ thể để nêu rỏ hơn yêu cầu của em, em xin các Thầy và các anh xem lại.
Nhấp chuột vào đây để mở rộng...

vậy thì ok rồi, code viết rất đẹp và chuyên nghiệp
bạn nên xóa dữ liệu cũ ở cột C:D và H:I trước khi bạnnạp nó vào mảng
Mã: 
arrTable = .Range("B3:I" & lngUbound).Value2
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

N
Tạo file lưu trữ dữ liệu tự động trên excel. (5 người xem)
Trả lời
3
Đọc
33
BuiQuangThuan
B
N
  • Question Question
Tạo file lưu trữ dự liệu tự động (7 người xem)
Trả lời
0
Đọc
10
nguyenle01
N
ongke0711
  • Question Question
Tra cứu thông tin mã số thuế (cập nhật lại code cũ)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
9
Đọc
491
ongke0711
ongke0711
Ả
Cách tạo list Data validation không qua trung gian (2 người xem)
Trả lời
45
Đọc
7K
HOADINH84
H
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (3 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
395
Đọc
47K
phamvanquoc.hanamninh
P
V
  • Question Question
Tạo dữ liệu random cho từng sheet dựa theo dữ liệu có sẵn (2 người xem)
Trả lời
3
Đọc
125
HieuCD
H
hieuxd
  • Question Question
Khi nhập dữ liệu tự động chèn thêm dòng khi số dòng trong bảng mẫu sắp hết (3 người xem)
Trả lời
26
Đọc
25K
dungpham01
D
D
in ra bị thiếu chữ
Trả lời
4
Đọc
86
dankedun
D
Momominh
Hỏi công thức tìm tuần thiếu hàng (1 người xem)
Trả lời
1
Đọc
71
hoangtuaotrang_hp_vn
H
2
EM MUỐN TẠO MA TRẬN BIẾN ĐỔI GIÁ TRỊ PHẦN TỬ NGẪU NHIÊN (2 người xem)
Trả lời
2
Đọc
66
ptm0412
ptm0412
Emyeuexcel
Cộng 4 tuần theo 1 qui luật qui định
Trả lời
34
Đọc
2K
Emyeuexcel
Emyeuexcel
Gà Con yêu VBA
Mở Pass file excel phiên bản .xlsx , xlsm, xlsb (1 người xem)
Trả lời
6
Đọc
287
YêuCN
Y
S
Mở 2 cửa sổ riêng biệt
Trả lời
31
Đọc
24K
ThanhNgan240723
T
vn81206
TRA CỨU MÃ SỐ THUẾ CÁ NHÂN QUA EXCEL
    • Buồn
Trả lời
57
Đọc
20K
vovietdung261016
V
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Thích
    • Cảm ơn
Trả lời
7
Đọc
1K
PhanTuHuong
PhanTuHuong
huuthang_bd
Add in SwitchSheet: Quay lại các sheet đã xem trước đó bằng phím tắt
    • Thích
    • Yêu thích
2
Trả lời
146
Đọc
43K
phong_codon
P
N
  • Question Question
Hỗ trợ tiếng việt trong macro (1 người xem)
Trả lời
14
Đọc
607
Quang_Hải
Quang_Hải
N
Cài phần mềm đọc số ra chữ
Trả lời
2
Đọc
142
Nguyễn Duy Tuân
Nguyễn Duy Tuân
T
Em cần hỗ trợ tách nhiều file và đặt tên theo quy ước chung từ bảng 01 excel có sẳng
Trả lời
1
Đọc
122
HUONGHCKT
H
N
hàm đếm theo dòng
Trả lời
1
Đọc
100
dungpham01
D
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom