hoangvinh_tb
Thành viên mới

- Tham gia
- 16/6/08
- Bài viết
- 20
- Được thích
- 4
Mã nó đâyMình gửi vd lên nhờ các bắc bớt chút thời gian chỉ dùm vài chiêu
Cảm ơn các bạn nhiều!!!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d, I, Vung, Ws
Set d = CreateObject("scripting.dictionary")
Set Ws = Sheets("MA")
Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3)
If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
If Target.Count = 1 Then
For I = 1 To UBound(Vung)
d.Add Vung(I, 1), Array(Vung(I, 2), Vung(I, 3))
Next I
If d.exists(UCase(Target.Value)) Then
Target.Offset(, 1) = d.Item(UCase(Target.Value))(0)
Target.Offset(, 2) = d.Item(UCase(Target.Value))(1)
End If
End If
End If
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B4:B99")) Is Nothing Then
Dim Rng As Range, sRng As Range, Sh As Worksheet
Set Sh = ThisWorkbook.Worksheets("MA")
Set Rng = Sh.Range(Sh.[b2], Sh.[b2].End(xlDown))
Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
If sRng Is Nothing Then
MsgBox "Nothing"
Else
Target.Offset(, 1).Resize(, 2).Value = sRng.Offset(, 1).Resize(, 2).Value
End If
End If
End Sub
Cám ơn bạn đã gửi cho mình đoạn mã này! nhưng mình muốn triển khai đoạn mã đó mà vẫn chưa làm đc mong bạn giải thích và giúp mình nhé
Mình muốn cột địa chỉ di chuyển các cột tên khoảng 5 cột
cám ơn bạn đã góp chân thành mình cũng định gửi file đính kèm mà không có cách nào đính kèm đc mong bạn và các bạn trong diễn đàn thông cảm.5 cột ấy là những cột nào vậy bạn ? Nhiều người trên diễn đàn (trong đó có tôi) cho rằng hỏi bài mà không gửi file đính kèm và không diễn đạt rõ yêu cầu là thiếu trách nhiệm với câu hỏi của mình và thiếu tôn trọng người mình hỏi.
Mình cũng đang cần cái này, cảm ơn pro. cái này hay lắm. Mình làm cửa hàng bán lẻ, hằng ngày phải xuất kho tương đối nhiều phiếu giao hàng trong 1 thời gian ngắn. Dùng hàm vlookup file excel lên đến 150MB nhìn đã thấy khiếp. đang tìm mã vba để thay thế vlookup. Thank pro nhé.Mã nó đây
RightClick vào sheet "CT" ==> View Code chép cái này vào
ThânMã:Private Sub Worksheet_Change(ByVal Target As Range) Dim d, I, Vung, Ws Set d = CreateObject("scripting.dictionary") Set Ws = Sheets("MA") Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3) If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then If Target.Count = 1 Then For I = 1 To UBound(Vung) d.Add Vung(I, 1), Array(Vung(I, 2), Vung(I, 3)) Next I If d.exists(UCase(Target.Value)) Then Target.Offset(, 1) = d.Item(UCase(Target.Value))(0) Target.Offset(, 2) = d.Item(UCase(Target.Value))(1) End If End If End If End Sub
code này hay, lâu nay mình lại dùng 2 vòng for hèn gì mà khi dữ liệu nhiều thì tìm kiếm lâu lắc.Mã nó đây
RightClick vào sheet "CT" ==> View Code chép cái này vào
ThânMã:Private Sub Worksheet_Change(ByVal Target As Range) Dim d, I, Vung, Ws Set d = CreateObject("scripting.dictionary") Set Ws = Sheets("MA") Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3) If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then If Target.Count = 1 Then For I = 1 To UBound(Vung) d.Add Vung(I, 1), Array(Vung(I, 2), Vung(I, 3)) Next I If d.exists(UCase(Target.Value)) Then Target.Offset(, 1) = d.Item(UCase(Target.Value))(0) Target.Offset(, 2) = d.Item(UCase(Target.Value))(1) End If End If End If End Sub
Sub TimKiem_Vlookup()
Dim i As Long, j As Long, sArray1, sArray2, Arr()
With Sheets("MA")
sArray1 = .Range(.[B3], .[B65000].End(xlUp)).Resize(, 3).Value
End With
With Sheets("CT")
.Range("C4:D65000").ClearContents
sArray2 = .Range(.[B4], .[B65000].End(xlUp)).Value
ReDim Arr(1 To UBound(sArray2, 1), 1 To 2)
For j = 1 To UBound(sArray2, 1)
For i = 1 To UBound(sArray1, 1)
If Not IsEmpty(sArray2(j, 1)) And sArray1(i, 1) = UCase(sArray2(j, 1)) Then
Arr(j, 1) = sArray1(i, 2)
Arr(j, 2) = sArray1(i, 3)
End If
Next
Next
.Range("C4").Resize(j - 1, 2).Value = Arr
End With
End Sub
Chào bác concogia và các cao thủ.Mã nó đây
RightClick vào sheet "CT" ==> View Code chép cái này vào
ThânMã:Private Sub Worksheet_Change(ByVal Target As Range) Dim d, I, Vung, Ws Set d = CreateObject("scripting.dictionary") Set Ws = Sheets("MA") Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3) If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then If Target.Count = 1 Then For I = 1 To UBound(Vung) d.Add Vung(I, 1), Array(Vung(I, 2), Vung(I, 3)) Next I If d.exists(UCase(Target.Value)) Then Target.Offset(, 1) = d.Item(UCase(Target.Value))(0) Target.Offset(, 2) = d.Item(UCase(Target.Value))(1) End If End If End If End Sub
Code trên là viết theo đề bài của bạn hoangvinh_tb, còn nếu theo ý của bạn thì ta vẫn viết theo cách cũ + một vòng lặp For ...... Next nữa, tức là một vòng tạo Dictionary, một vòng lấy mảng kết quảcode này hay, lâu nay mình lại dùng 2 vòng for hèn gì mà khi dữ liệu nhiều thì tìm kiếm lâu lắc.
==============================================
Sau khi thử code trên mình thấy chỉ tìm kiếm được cho từng mã khi click vào ô đó (tức là nhập vào giá trị mã cho ô đó thì sẽ tìm kiếm cho mã tại ô đó). Vậy nếu mình có sẵn 1 danh sách mã và muốn tìm kiếm cho 1 danh sách mã đó thì ko lẽ phải click từng mã mới tìm kiếm được. Mình vẫn phải dùng 2 vòng For, 1 vòng for cho vùng chứa dữ liệu tìm kiếm và 1 vòng for cho vùng chứa mã muốn tìm kiếm. Với cách này dữ liệu hàng chục ngàn dòng thì code chạy lâu, có cách nào khác không nhỉ?
PHP:Sub TimKiem_Vlookup() Dim i As Long, j As Long, sArray1, sArray2, Arr() With Sheets("MA") sArray1 = .Range(.[B3], .[B65000].End(xlUp)).Resize(, 3).Value End With With Sheets("CT") .Range("C4:D65000").ClearContents sArray2 = .Range(.[B4], .[B65000].End(xlUp)).Value ReDim Arr(1 To UBound(sArray2, 1), 1 To 2) For j = 1 To UBound(sArray2, 1) For i = 1 To UBound(sArray1, 1) If Not IsEmpty(sArray2(j, 1)) And sArray1(i, 1) = UCase(sArray2(j, 1)) Then Arr(j, 1) = sArray1(i, 2) Arr(j, 2) = sArray1(i, 3) End If Next Next .Range("C4").Resize(j - 1, 2).Value = Arr End With End Sub
Bạn chép code này đè lên cái cũ nhéChào bác concogia và các cao thủ.
EM đang cần làm 1 cái phiếu xuất kho cũng thay thế hàm vlookup bằng mã VBA, copy mã của bác concogia về chạy thử thì rất ok. Chỉ có điều em muốn link thêm giá trị từ Sheet 'MA' sang sheet 'CT', mà ko biết sửa thế nào nhờ bác concogia và các cao thủ sử giúp. Em xin cảm ơn các bác.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d, I, Vung, Ws
Set d = CreateObject("scripting.dictionary")
Set Ws = Sheets("MA")
Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 4)
If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
If Target.Count = 1 Then
For I = 1 To UBound(Vung)
d.Add Vung(I, 1), Array(Vung(I, 2), Vung(I, 3), Vung(I, 4))
Next I
If d.exists(UCase(Target.Value)) Then
Target.Offset(, 1) = d.Item(UCase(Target.Value))(0)
Target.Offset(, 2) = d.Item(UCase(Target.Value))(1)
Target.Offset(, 5) = d.Item(UCase(Target.Value))(2)
End If
End If
End If
End Sub
m mò ra rồi, Cảm ơn các bác nhiều...Chào bác concogia và các cao thủ.
EM đang cần làm 1 cái phiếu xuất kho cũng thay thế hàm vlookup bằng mã VBA, copy mã của bác concogia về chạy thử thì rất ok. Chỉ có điều em muốn link thêm giá trị từ Sheet 'MA' sang sheet 'CT', mà ko biết sửa thế nào nhờ bác concogia và các cao thủ sử giúp. Em xin cảm ơn các bác.
Bạn chép code này đè lên cái cũ nhé
ThânMã:Private Sub Worksheet_Change(ByVal Target As Range) Dim d, I, Vung, Ws Set d = CreateObject("scripting.dictionary") Set Ws = Sheets("MA") Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 4) If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then If Target.Count = 1 Then For I = 1 To UBound(Vung) d.Add Vung(I, 1), Array(Vung(I, 2), Vung(I, 3), Vung(I, 4)) Next I If d.exists(UCase(Target.Value)) Then Target.Offset(, 1) = d.Item(UCase(Target.Value))(0) Target.Offset(, 2) = d.Item(UCase(Target.Value))(1) Target.Offset(, 5) = d.Item(UCase(Target.Value))(2) End If End If End If End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I, Vung, Ws
Set Ws = Sheets("MA")
Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 4)
If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
If Target.Count = 1 Then
For I = 1 To UBound(Vung)
If Vung(I, 1) = Ucase(Target.Value) Then
Target.Offset(, 1) = Vung(I, 2)
Target.Offset(, 2) = Vung(I, 3)
Target.Offset(, 5) = Vung(I, 4)
Exit For
End If
Next I
End If
End If
End Sub
Tôi thấy có vẻ nhiều người hơi lạm dụng Dictionary. Dictionary mạnh và không dễ thay thế được trong một vài trường hợp không có nghĩa là nó tốt cho mọi trường hợp. Tỏi nếu nấu với món "này" thì tuyệt nhưng không có nghĩa là nấu món nào cũng cho tỏi. Không phải mổ trâu, lợn, gà, bóc tỏi, gọt táo đều dùng dao mổ trâu. Lợi thì chắc không mà hại thì nhiều.
Sửa một chút code trên thành
Mã:Private Sub Worksheet_Change(ByVal Target As Range) Dim I, Vung, Ws Set Ws = Sheets("MA") Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 4) If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then If Target.Count = 1 Then For I = 1 To UBound(Vung) If Vung(I, 1) = Ucase(Target.Value) Then Target.Offset(, 1) = Vung(I, 2) Target.Offset(, 2) = Vung(I, 3) Target.Offset(, 5) = Vung(I, 4) Exit For End If Next I End If End If End Sub
nếu tôi không lầm thì code tốt hơn. Trong trường hợp xấu nhất thì cũng chỉ phải duyệt (FOR) tất cả các dòng của Vung, còn trong trường hợp tốt nhất thì chỉ duyệt có 1 dòng. Dùng Dictionary như trên luôn phải duyệt tất cả các dòng, rồi với mỗi dòng đó làm "động tác" d.Add ... (thừa)
Nếu số dòng không phải là "vài" mà là "mấy trăm" (mã không phải là A --> Z mà là vd. wxyz) thì chắc chắn code dùng Dictionary như trên sẽ làm nhiều việc hơn, lâu hơn.
Bạn có thể thêm đoạn code màu đỏ này vào code của bạn Concogia, cách làm tương tự nếu bạn muốn xóa thêm phần nào đó cho mã đó.
Chào bác 'concogia', em đã làm theo cách của bác, file excel của em chạy rất ổn, dung lượng file giảm từ 150MB xuống còn 24MB, quá tuyệt luôn. File nhanh, tuy nhiên em gặp một số vấn đề cần bác phát triển thêm giúp em.Bạn chép code này đè lên cái cũ nhé
ThânMã:Private Sub Worksheet_Change(ByVal Target As Range) Dim d, I, Vung, Ws Set d = CreateObject("scripting.dictionary") Set Ws = Sheets("MA") Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 4) If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then If Target.Count = 1 Then For I = 1 To UBound(Vung) d.Add Vung(I, 1), Array(Vung(I, 2), Vung(I, 3), Vung(I, 4)) Next I If d.exists(UCase(Target.Value)) Then Target.Offset(, 1) = d.Item(UCase(Target.Value))(0) Target.Offset(, 2) = d.Item(UCase(Target.Value))(1) Target.Offset(, 5) = d.Item(UCase(Target.Value))(2) End If End If End If End Sub
Em đã thử cách của bác nhưng khi thao tác xóa từng ô thì các giá trị ở cột sản phẩm, đơn vị, đơn giá cũng mất. nhưng nếu quét nhiều ô để xóa thì các giá trị khác vẫn giữ nguyên. làm thế nào để khi quét nhiều ô để xóa thì các giá trị khác cũng bị xóa hả bác 'qtm1987'Bạn có thể thêm đoạn code màu đỏ này vào code của bạn Concogia, cách làm tương tự nếu bạn muốn xóa thêm phần nào đó cho mã đó.
....
If d.exists(UCase(Target.Value)) Then
Target.Offset(, 1) = d.Item(UCase(Target.Value))(0)
Target.Offset(, 2) = d.Item(UCase(Target.Value))(1)
ElseIf IsEmpty(Target) Then
Target.Offset(, 1) = ""
Target.Offset(, 2) = ""
End If
...
Đây là thiếu sót của tất cả các code từ đầu topic đến giờEm đã thử cách của bác nhưng khi thao tác xóa từng ô thì các giá trị ở cột sản phẩm, đơn vị, đơn giá cũng mất. nhưng nếu quét nhiều ô để xóa thì các giá trị khác vẫn giữ nguyên. làm thế nào để khi quét nhiều ô để xóa thì các giá trị khác cũng bị xóa hả bác 'qtm1987'
Đây chính là lúc dùng đến Dictionary nè!Tôi thấy có vẻ nhiều người hơi lạm dụng Dictionary. Dictionary mạnh và không dễ thay thế được trong một vài trường hợp không có nghĩa là nó tốt cho mọi trường hợp. Tỏi nếu nấu với món "này" thì tuyệt nhưng không có nghĩa là nấu món nào cũng cho tỏi. Không phải mổ trâu, lợn, gà, bóc tỏi, gọt táo đều dùng dao mổ trâu. Lợi thì chắc không mà hại thì nhiều.
Sửa một chút code trên thành
.
Đây là thiếu sót của tất cả các code từ đầu topic đến giờ
Dùng sự kiện Worksheet_Change phải biết rằng Target không phải luôn là 1 cell ---> Đôi khi ngươi ta copy/paste( hoặc quét chọn khối cell rồi Delete như bạn làm) thì sao?
Chính vì thế phải cho thêm công đoạn quét toàn bộ các cell thuộc Target (For Each Clls in Target chẳng hạn)
Nói chung dạng bài này cũng đã từng post trên diễn đàn rồi... nếu khéo léo, có thể dùng Array để tăng tốc bảng tính
Các bạn khác đang nghiên cứu về VBA code thừ cải tiến lại xem
(tôi làm hoài dạng này đâm chán luôn)
--------------------------------------
Đây chính là lúc dùng đến Dictionary nè!
Tuy nhiên, nếu khéo hơn thì ta chỉ tạo và nạp Dictionary 1 lần duy nhất (nếu Dictionary chưa được tạo) ---> Những lần sau đó của sự kiện Change, chỉ việc "vào" Dic "moi" ra xài thôi