Hiện mã và tên vật liệu khi chọn chuột vào ô chữa mã sản phẩm?

NH_DK · 17/9/11

Em có ví dụ này nhờ mọi người xem và thiết lập cho em. Câu hỏi cụ thể trong file đính kèm!

Liệu có giải pháp nào không?

NH_DK · 18/9/11

Ví dụ này có cách nào xử lý không ah?

PhanTuHuong · 18/9/11

Chờ mình xem nhé, tối qua mệt nên ngủ sớm

PhanTuHuong · 18/9/11

Em thử nghiên cứu Validation đi

nghiaphuc · 18/9/11

NH_DK đã viết:
Em có ví dụ này nhờ mọi người xem và thiết lập cho em. Câu hỏi cụ thể trong file đính kèm!

Download file

Liệu có giải pháp nào không?

Thử món này xem sao:

PHP:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim VL As String, Cll As Range
    If Target.Count > 1 Or Intersect(Target, Range([A2], [A100].End(xlUp))) Is Nothing Then Exit Sub
    For Each Cll In Sheet1.Range(Sheet1.[A1], Sheet1.[A10000].End(xlUp))
        If Cll.Value = Target.Value Then
            VL = VL & vbCr & Cll.Offset(, 1) & "   |   " & Cll.Offset(, 2)
        End If
    Next
    If Len(VL) > 0 Then MsgBoxUni VL, , "Ma san pham " & Target.Value
End Sub

Trong file có sử dụng hàm MsgBoxUni của anh Nguyễn Duy Tuân. Cảm ơn anh!
Nếu lượng dữ liệu lớn thì có lẽ thay vòng For-Next thành vòng Do-While và set biến Cll bởi phương thức Find sẽ nhanh hơn.

ndu96081631 · 18/9/11

nghiaphuc đã viết:
Thử món này xem sao:

PHP:

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim VL As String, Cll As Range If Target.Count > 1 Or Intersect(Target, Range([A2], [A100].End(xlUp))) Is Nothing Then Exit Sub For Each Cll In Sheet1.Range(Sheet1.[A1], Sheet1.[A10000].End(xlUp)) If Cll.Value = Target.Value Then VL = VL & vbCr & Cll.Offset(, 1) & " | " & Cll.Offset(, 2) End If Next If Len(VL) > 0 Then MsgBoxUni VL, , "Ma san pham " & Target.Value End Sub

Trong file có sử dụng hàm MsgBoxUni của anh Nguyễn Duy Tuân. Cảm ơn anh!
Nếu lượng dữ liệu lớn thì có lẽ thay vòng For-Next thành vòng Do-While và set biến Cll bởi phương thức Find sẽ nhanh hơn.

Mình nghĩ hiện kết quả vào 1 Comment hoặc cái gì đó tương tự sẽ hay hơn ---> MsgBox cứ bấm hoài, mỏi tay lắm
(bấm vào đúng vùng hoạt động thì Add và hiện comment, ngược lại thì xóa comment)

nghiaphuc · 18/9/11

ndu96081631 đã viết:
Mình nghĩ hiện kết quả vào 1 Comment hoặc cái gì đó tương tự sẽ hay hơn ---> MsgBox cứ bấm hoài, mỏi tay lắm
(bấm vào đúng vùng hoạt động thì Add và hiện comment, ngược lại thì xóa comment)

Theo gợi ý của bác ndu, em làm ra cái này. Bác cho ý kiến nhé:

PHP:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cll As Range, n As Long, VL As String, i As Integer
    
    [A:A].ClearComments
    If Target.Count > 1 Or Intersect(Target, Range([A2], [A10000].End(xlUp))) Is Nothing Then Exit Sub
    VL = ""
    With Sheet1
        On Error GoTo AddCom
        Set Cll = .[A:A].Find(Target.Value, .[A1], , xlWhole)
        n = Cll.Row
        Do
            i = i + 1
            VL = VL & Chr(10) & Cll.Offset(, 1) & "   |   " & Cll.Offset(, 2)
            Set Cll = .[A:A].Find(Target.Value, Cll, , xlWhole)
        Loop Until Cll.Row = n
    End With
AddCom:
    With Target
        .AddComment
        .Comment.Visible = True
        .Comment.Text VL
        .Comment.Shape.Height = 25 + 10 * i
    End With
End Sub

(đang dùng máy trên trường nên không có Excel 2007 --> làm đại 1 file trên Excel 2003, hình như là có cấu trúc giống file của NH_DK)

tintam7251 · 19/9/11

Nguyên văn bởi nghiaphuc
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Cll As Range, n As Long, VL As String, i As Integer
[A:A].ClearComments
If Target.Count > 1 Or Intersect(Target, Range([A2], [A10000].End(xlUp))) Is Nothing Then Exit Sub
VL = ""
With Sheet1
On Error GoTo AddCom
Set Cll = .[A:A].Find(Target.Value, .[A1], , xlWhole)
n = Cll.Row
Do
i = i + 1
VL = VL & Chr(10) & Cll.Offset(, 1) & " | " & Cll.Offset(, 2)
Set Cll = .[A:A].Find(Target.Value, Cll, , xlWhole)
Loop Until Cll.Row = n
End With
AddCom:
With Target
.AddComment
.Comment.Visible = True
.Comment.Text VL
.Comment.Shape.Height = 25 + 10 * i
End With
End Sub

Theo mình, đã dùng Find nên dùng thêm FindNext cho gọn hơn.

NH_DK · 19/9/11

nghiaphuc đã viết:

Theo gợi ý của bác ndu, em làm ra cái này. Bác cho ý kiến nhé:

PHP:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cll As Range, n As Long, VL As String, i As Integer
    
    [A:A].ClearComments
    If Target.Count > 1 Or Intersect(Target, Range([A2], [A10000].End(xlUp))) Is Nothing Then Exit Sub
    VL = ""
    With Sheet1
        On Error GoTo AddCom
        Set Cll = .[A:A].Find(Target.Value, .[A1], , xlWhole)
        n = Cll.Row
        Do
            i = i + 1
            VL = VL & Chr(10) & Cll.Offset(, 1) & "   |   " & Cll.Offset(, 2)
            Set Cll = .[A:A].Find(Target.Value, Cll, , xlWhole)
        Loop Until Cll.Row = n
    End With
AddCom:
    With Target
        .AddComment
        .Comment.Visible = True
        .Comment.Text VL
        .Comment.Shape.Height = 25 + 10 * i
    End With
End Sub

(đang dùng máy trên trường nên không có Excel 2007 --> làm đại 1 file trên Excel 2003, hình như là có cấu trúc giống file của NH_DK)

Anh ơi, thế này thì đúng ý em rùi. Cho em hỏi thêm nhé: Em muốn phần trên cùng của comment nó hiện thêm Mã vật liệu - Tên vật liệu (có thể hiện luôn thông tin ở ô tiêu đề)?
Cám ơn anh nhiều!

nghiaphuc · 19/9/11

NH_DK đã viết:
Anh ơi, thế này thì đúng ý em rùi. Cho em hỏi thêm nhé: Em muốn phần trên cùng của comment nó hiện thêm Mã vật liệu - Tên vật liệu (có thể hiện luôn thông tin ở ô tiêu đề)?
Cám ơn anh nhiều!

Theo góp ý của anh tintam7251 (sử dụng FindNext), mình sửa lại code như vầy, Ngọc xem đúng ý chưa nhé:

PHP:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cll As Range, n As Long, VL As String, i As Integer
    
    [A:A].ClearComments
    If Target.Count > 1 Or Intersect(Target, Range([A2], [A10000].End(xlUp))) Is Nothing Then Exit Sub
    With Sheet1
        VL = .[B1] & " | " & .[C1] 'Tiêu đề của Comment: Mã vật liệu - Tên vật liệu'
        On Error GoTo AddCom
        Set Cll = .[A:A].Find(Target.Value, .[A1], , xlWhole)
        n = Cll.Row
        Do
            i = i + 1
            VL = VL & Chr(10) & Cll.Offset(, 1) & "      |      " & Cll.Offset(, 2)
            Set Cll = .[A:A].FindNext(Cll)
        Loop Until Cll.Row = n
    End With
AddCom:
    With Target
        .AddComment
        .Comment.Visible = True
        .Comment.Text VL
        .Comment.Shape.TextFrame.AutoSize = True 'Tự động chỉnh kích thước Comment tùy thuộc nội dung'
    End With
End Sub

NH_DK · 19/9/11

nghiaphuc đã viết:

Theo góp ý của anh tintam7251 (sử dụng FindNext), mình sửa lại code như vầy, Ngọc xem đúng ý chưa nhé:

PHP:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cll As Range, n As Long, VL As String, i As Integer
    
    [A:A].ClearComments
    If Target.Count > 1 Or Intersect(Target, Range([A2], [A10000].End(xlUp))) Is Nothing Then Exit Sub
    With Sheet1
        VL = .[B1] & " | " & .[C1] 'Tiêu đề của Comment: Mã vật liệu - Tên vật liệu'
        On Error GoTo AddCom
        Set Cll = .[A:A].Find(Target.Value, .[A1], , xlWhole)
        n = Cll.Row
        Do
            i = i + 1
            VL = VL & Chr(10) & Cll.Offset(, 1) & "      |      " & Cll.Offset(, 2)
            Set Cll = .[A:A].FindNext(Cll)
        Loop Until Cll.Row = n
    End With
AddCom:
    With Target
        .AddComment
        .Comment.Visible = True
        .Comment.Text VL
        .Comment.Shape.TextFrame.AutoSize = True 'Tự động chỉnh kích thước Comment tùy thuộc nội dung'
    End With
End Sub

Như vậy thì Ok rùi anh ah. Nhưng cho em hởi thêm chút xíu nữa ha: Em muốn thông tin của từng cột hiện đúng cột của nó? Vì thực tế còn có những mã, tên, ... nếu cứ để như thế này thì sẽ nhìn rất xấu ah?

nghiaphuc · 19/9/11

NH_DK đã viết:
Như vậy thì Ok rùi anh ah. Nhưng cho em hởi thêm chút xíu nữa ha: Em muốn thông tin của từng cột hiện đúng cột của nó? Vì thực tế còn có những mã, tên, ... nếu cứ để như thế này thì sẽ nhìn rất xấu ah?

Mình nghĩ đến việc thay Comment bởi 1 Listbox hay 1 Listview động. Mỗi lần chọn trong vùng chỉ định thì khởi tạo Listbox/Listview (nạp dữ liệu thỏa mãn), sau đó cho hiện lên tại ô chọn (sử dụng các thuộc tính Top, Left, Visible). Ngược lại thì ẩn Listbox/Listview. Tuy nhiên, với Listbox thì có lẽ cũng không cải thiện được về mặt thẩm mỹ, còn Listview thì thú thật là mình hoàn toàn mù tịt, chưa dùng bao giờ, hình như Listview không hiển thị được tiếng Việt Unicode mà phải chuyển mã sang TCVN-3.
Thôi đành nhờ các thành viên rành hơn về Listview ra tay giúp đỡ. (không dám nói là cao thủ, sợ mọi người... ngại, cuối cùng người chịu thiệt lại là mình!)

ndu96081631 · 20/9/11

nghiaphuc đã viết:
Mình nghĩ đến việc thay Comment bởi 1 Listbox hay 1 Listview động. Mỗi lần chọn trong vùng chỉ định thì khởi tạo Listbox/Listview (nạp dữ liệu thỏa mãn), sau đó cho hiện lên tại ô chọn (sử dụng các thuộc tính Top, Left, Visible). Ngược lại thì ẩn Listbox/Listview. Tuy nhiên, với Listbox thì có lẽ cũng không cải thiện được về mặt thẩm mỹ, còn Listview thì thú thật là mình hoàn toàn mù tịt, chưa dùng bao giờ, hình như Listview không hiển thị được tiếng Việt Unicode mà phải chuyển mã sang TCVN-3.

Tôi có chiêu này (không dùng listbox hay listview) dùng CopyPicture, xem thử thế nào nha
- Đầu tiên dùng hàm Filter2DArray lọc dữ liệu ra 1 vùng tạm
- Xong, copy vùng tạm này thành 1 Picture rồi hiển thị nó tại vị trí của Target

PHP:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim sArray, Arr
  On Error Resume Next
  Target.Parent.Pictures.Delete
  If Target.Column = 1 And Target.Count = 1 And Target.Value <> "" Then
    With Sheet1
      .Range("L:N").ClearContents
      sArray = .Range(.[A1], .[A65536].End(xlUp)).Resize(, 3)
      Arr = Filter2DArray(sArray, 1, Target(1, 1).Value, True)
      .Range("L1").Resize(UBound(Arr, 1), 3) = Arr
      .Range("L1").CurrentRegion.CopyPicture
      Target.Parent.Paste Target.Offset(, 1)
    End With
    Target.Select
    Application.ScreenUpdating = True
  End If
End Sub

Xem file ---> Bảo đảm hiển thị không đẹp không ăn tiền

NH_DK · 20/9/11

Thế này OK lắm sư phụ ah! Giờ em muốn thêm 2 cột nữa trong phần sheet Data (cột số lượng và cột ghi chú). Tất nhiên 2 cột này cũng có mặt trong phần xem rùi (sheet info). Sư phụ sửa thêm phần code dùm em nhé! Em vẫn chưa sửa được ah!
Cám ơn sư phụ nhiều!

ndu96081631 · 20/9/11

NH_DK đã viết:
Thế này OK lắm sư phụ ah! Giờ em muốn thêm 2 cột nữa trong phần sheet Data (cột số lượng và cột ghi chú). Tất nhiên 2 cột này cũng có mặt trong phần xem rùi (sheet info). Sư phụ sửa thêm phần code dùm em nhé! Em vẫn chưa sửa được ah!
Cám ơn sư phụ nhiều!

Chú ý chổ màu đỏ này:

Mã:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim sArray, Arr
  On Error Resume Next
  Target.Parent.Pictures.Delete
  If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 And Target.Value <> "" Then
    With Sheet1
      .[COLOR=#ff0000][B]Range("L:N")[/B][/COLOR].ClearContents
      sArray = .Range(.[A1], .[A65536].End(xlUp)).Resize(, [COLOR=#ff0000][B]3[/B][/COLOR])
      Arr = Filter2DArray(sArray, 1, Target(1, 1).Value, True)
      .Range("L1").Resize(UBound(Arr, 1), [COLOR=#ff0000][B]3[/B][/COLOR]) = Arr
      .Range("L1").CurrentRegion.CopyPicture
      Target.Parent.Paste Target.Offset(, 1)
    End With
    Target.Select
    Application.ScreenUpdating = True
  End If
End Sub

Sửa số 3 thành số 5 thì ra 5 cột thôi
Range("L:N") sửa thành Range("L")
Đương nhiên bạn phải trang trí lại vùng tạm (bên sheet Data) cho kết quả ở Info được đẹp hơn

NH_DK · 20/9/11

ndu96081631 đã viết:
Chú ý chổ màu đỏ này:

Mã:

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim sArray, Arr On Error Resume Next Target.Parent.Pictures.Delete If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 And Target.Value <> "" Then With Sheet1 .[COLOR=#ff0000][B]Range("L:N")[/B][/COLOR].ClearContents sArray = .Range(.[A1], .[A65536].End(xlUp)).Resize(, [COLOR=#ff0000][B]3[/B][/COLOR]) Arr = Filter2DArray(sArray, 1, Target(1, 1).Value, True) .Range("L1").Resize(UBound(Arr, 1), [COLOR=#ff0000][B]3[/B][/COLOR]) = Arr .Range("L1").CurrentRegion.CopyPicture Target.Parent.Paste Target.Offset(, 1) End With Target.Select Application.ScreenUpdating = True End If End Sub

Sửa số 3 thành số 5 thì ra 5 cột thôi
Range("L:N") sửa thành Range("L")
Đương nhiên bạn phải trang trí lại vùng tạm (bên sheet Data) cho kết quả ở Info được đẹp hơn

Em không muốn hiện cột mã sản phẩm? Em tìm mãi mà sửa không được. Phiền sư phụ chỉ dùm em thêm chút nữa nha!

nghiaphuc · 21/9/11

NH_DK đã viết:
Em không muốn hiện cột mã sản phẩm? Em tìm mãi mà sửa không được. Phiền sư phụ chỉ dùm em thêm chút nữa nha!

Sửa lại code như vầy là OK:

Mã:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim sArray, Arr
  On Error Resume Next
  Target.Parent.Pictures.Delete
  [COLOR=#ff0000]If Target.Count > 1 Or Intersect(Target, [A:A], UsedRange) Is Nothing Then Exit Sub
  If Target.Row > 1 And Target.Value <> "" Then
[/COLOR]   With Sheet1
      .Range("L:[COLOR=#ff0000]P[/COLOR]").ClearContents
      sArray = .Range(.[A1], .[A65536].End(xlUp)).Resize(, [COLOR=#ff0000]5[/COLOR])
      Arr = Filter2DArray(sArray, 1, Target(1, 1).Value, True)
      .Range("L1").Resize(UBound(Arr, 1), [COLOR=#ff0000]5[/COLOR]) = Arr
      [COLOR=#ff0000].Range(.[M1], .[M65536].End(xlUp)).Resize(, 4)[/COLOR].CopyPicture
      Target.Parent.Paste Target.Offset(, 1)
    End With
    Target.Select
    Application.ScreenUpdating = True
  End If
End Sub

@ndu: Trong code của bác, có 2 câu này:

Mã:

[COLOR=#ff0000]On Error Resume Next[/COLOR]
If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 And [COLOR=#ff0000]Target.Value <> ""[/COLOR] Then

Do đó, nếu em chọn một vùng bất kỳ trên sheet Info, chỉ cần Target.Count > 1 thì toàn bộ biểu thức logic này sẽ bị lỗi (vì không xác định được Target.Value) và nó sẽ nhảy qua câu lệnh kế tiếp --> kết quả hổng đẹp. Do đó, em tách câu

Mã:

If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 And Target.Value <> "" Then

thành 2 câu

Mã:

If Target.Count > 1 Or Intersect(Target, [A:A], UsedRange) Is Nothing Then Exit Sub
If Target.Row > 1 And Target.Value <> "" Then

ndu96081631 · 21/9/11

NH_DK đã viết:
Em không muốn hiện cột mã sản phẩm? Em tìm mãi mà sửa không được. Phiền sư phụ chỉ dùm em thêm chút nữa nha!

Trời đất ơi, cái này quá đơn giản mà bạn!
.Range("L1").CurrentRegion.CopyPicture ---> Copy toàn bộ kết quả
Giờ không muốn lấy cột đầu thì cứ việc "dịch" sang 1 cột thôi (dùng Offset)
Sửa nó thành:

PHP:

.Range("L1").CurrentRegion.Resize(, 4).Offset(, 1).CopyPicture

Hoặc:

PHP:

With .Range("L1").CurrentRegion
  Intersect(.Cells, .Offset(, 1)).CopyPicture
End With

(Đoạn dưới theo tôi là hay hơn --> Luôn dịch sang 1 cột mà không cần quan tâm dữ liệu đang có mấy cột)
-------------------------------

nghiaphuc đã viết:
@ndu: Trong code của bác, có 2 câu này:

Mã:

[COLOR=#ff0000]On Error Resume Next[/COLOR] If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 And [COLOR=#ff0000]Target.Value <> ""[/COLOR] Then

Do đó, nếu em chọn một vùng bất kỳ trên sheet Info, chỉ cần Target.Count > 1 thì toàn bộ biểu thức logic này sẽ bị lỗi (vì không xác định được Target.Value) và nó sẽ nhảy qua câu lệnh kế tiếp --> kết quả hổng đẹp.

Quả thật có sơ sót trong quá trình suy luận logic... Tuy nhiên khi viết code tôi ít khi thích Exit Sub (dù cũng có xài), nên tôi sẽ sửa thế này:

Mã:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim sArray, Arr
  On Error Resume Next
  Target.Parent.Pictures.Delete
  If Target.Count = 1 Then
    If Target.Column = 1 And Target.Row > 1 And Target.Value <> "" Then
      With Sheet1
        .Range("L1").CurrentRegion.ClearContents
        sArray = .Range(.[A1], .[A65536].End(xlUp)).Resize(, [COLOR=#0000cd][B]5[/B][/COLOR])
        Arr = Filter2DArray(sArray, 1, Target(1, 1).Value, True)
        [COLOR=#ff0000][B]If TypeName(Arr) = "Variant()" Then[/B][/COLOR]
          .Range("L1").Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr
          With .Range("L1").CurrentRegion
            Intersect(.Cells, .Offset(, 1)).CopyPicture
          End With
          Target.Parent.Paste Target.Offset(, 1)
        End If
      End With
      Target.Select
      Application.ScreenUpdating = True
    End If
  End If
End Sub

Điều kiện Target.Count được xét trước tiên ---> Ổn chứ
Ngoài ra:
- Thêm đoạn If TypeName(Arr) = "Variant()" Then sẽ chắc ăn hơn ---> Tức có trích được dữ liệu thì code mới làm việc tiếp
- Sửa 1 vài đoạn để code mang tính tổng quát hơn ---> Với code mới này, muốn trích ra mấy cột chỉ việc sửa số màu xanh ở trên là xong
- Code mới này thậm chí không cần On Error Resume Next cũng không có bất cứ lỗi gì... Tuy nhiên vẫn để đó dự phòng những trường hợp không lường trước

Hiện mã và tên vật liệu khi chọn chuột vào ô chữa mã sản phẩm?

Let's patience

Let's patience

VBA & VB.NET for Excel & AutoCad

VBA & VB.NET for Excel & AutoCad

Thành viên gạo cội

File đính kèm

Huyền thoại GPE

Thành viên gạo cội

File đính kèm

Thành viên thường trực

Let's patience

Thành viên gạo cội

File đính kèm

Let's patience

Thành viên gạo cội

Huyền thoại GPE

File đính kèm

Let's patience

Huyền thoại GPE

Let's patience

Thành viên gạo cội

File đính kèm

Huyền thoại GPE

File đính kèm

Đếm ngược thời gian