Giúp sửa code:Right Click để hiện các Form trên cùng một bảng tính. (1 người xem)

[Hong.Van]

Em chào Thầy cô & anh chị!
Em có tạo 2 Form, 2 Form này dùng để nhập liệu trên cùng bảng tính "TH"
1/ Form DMHH sẽ hiện tại cell K9 trở xuống của Sheet TH (Fím tắt: Ctrl+T)
2/ Form DMDG sẽ hiện tại cell AH9 trở xuống của Sheet TH (Fím tắt: Ctrl+Shift+Z)

Bây giờ em muốn sửa code để có thể Right Click tại cột K hiện Form DMHH. Và Right Click tại cột AH để hiện Form DMDG
----------------
Code này em sưu tầm trên GPE, lúc đầu chỉ có 1 Form trên 1 sheet thì em làm được
Bây giờ để hiện 2 hay nhiều Form thì em ... hổng biết cách
Mong các Thầy cô & anh chị giúp em. Em cảm ơn.
------------
Code trong Module

Sub ShowDMHH()    
On Error Resume Next
    If ActiveSheet.Name = "TH" Then
        If ActiveCell.Row > 8 Then
            If ActiveCell.Row < 12000 Then
                If ActiveCell.Column = 11 Then
                    FormDMMH.Show 1
                    Cancel = True
                End If: End If: End If: End If
End Sub


Private Sub BuildPopupMenu()
    With Application.CommandBars("Cell").Controls.Add(1, , , 1)
        .Caption = "Form DMHH"
        .OnAction = "ShowDMHH"
        .FaceId = 9895
    End With
End Sub
Private Sub ResetPopupMenu()
    Application.CommandBars("Cell").Reset
End Sub

Sub ShowDMDG()
On Error Resume Next
If ActiveSheet.Name = "TH" Then
  If ActiveCell.Row > 8 Then
    If ActiveCell.Row < 12000 Then
      If ActiveCell.Column = 34 Then
        FormDMDG.Show 1
        Cancel = True
End If: End If: End If: End If
End Sub




Private Sub BuildPopupMenu()
  With Application.CommandBars("Cell").Controls.Add(1, , , 1)
    .Caption = "Form DMDG"
    .OnAction = "ShowDMDG"
    .FaceId = 9895
  End With
End Sub
Private Sub ResetPopupMenu()
  Application.CommandBars("Cell").Reset
End Sub

Code trong ThisWorkbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Run ("ResetPopupMenu")
    
End Sub


Private Sub Workbook_Deactivate()
    Run ("ResetPopupMenu")
End Sub

Code của Form dài quá, vui lòng xem File

 

[viehoai]

Bây giờ em muốn sửa code để có thể Right Click tại cột K hiện Form DMHH. Và Right Click tại cột AH để hiện Form DMDG

Nếu thế thì như thế này là đủ. Chẳng hiểu ý bạn muốn gì thêm
[GPECODE=vb]Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If Not Intersect(Range("K9:K12000"), Target) Is Nothing Then
FormDMMH.Show
End If
If Not Intersect(Range("AH9:AH12000"), Target) Is Nothing Then
FormDMDG.Show
End If
End Sub


[/GPECODE]

 

[Hong.Van]

Nếu thế thì như thế này là đủ. Chẳng hiểu ý bạn muốn gì thêm
[GPECODE=vb]Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If Not Intersect(Range("K9:K12000"), Target) Is Nothing Then
FormDMMH.Show
End If
If Not Intersect(Range("AH9:AH12000"), Target) Is Nothing Then
FormDMDG.Show
End If
End Sub


[/GPECODE]

Em Sorry vì mô tả chưa kỹ, ý em là Khi Right Click thì tên Form sẽ hiện lên cùng với Form Right Click (nghĩa là cùng với Cut, Copy Paste ....) sau đó mình chọn Form để làm việc...
Bây giờ anh thử Right Click vào cột K của Sheet TH của File em gởi lên
Lưu ý: Form này không có Icon, thực tế em có làm Icon
---------
Cách trên của anh thì nó hiện thẳng ra luôn, nên muốn sử dụng các chức năng khác kg được!
Em cảm ơn
-------------

 

[siwtom]

Em chào Thầy cô & anh chị!
Em có tạo 2 Form, 2 Form này dùng để nhập liệu trên cùng bảng tính "TH"
1/ Form DMHH sẽ hiện tại cell K9 trở xuống của Sheet TH (Fím tắt: Ctrl+T)
2/ Form DMDG sẽ hiện tại cell AH9 trở xuống của Sheet TH (Fím tắt: Ctrl+Shift+Z)

Bây giờ em muốn sửa code để có thể Right Click tại cột K hiện Form DMHH. Và Right Click tại cột AH để hiện Form DMDG

1. Remove Tools_SS

2. code Module Tools
[GPECODE=vb]
Sub ShowDMHH()
On Error Resume Next
If ActiveSheet.name = "TH" And ActiveCell.Row > 8 And _
ActiveCell.Row < 12000 And ActiveCell.Column = 11 Then
FormDMMH.Show 1
End If
End Sub

Sub ShowDMDG()
On Error Resume Next
If ActiveSheet.name = "TH" And ActiveCell.Row > 8 And _
ActiveCell.Row < 12000 And ActiveCell.Column = 34 Then
FormDMDG.Show 1
End If:
End Sub

Sub BuildPopupMenu(ByVal name As String)
With Application.CommandBars("Cell").Controls.Add(1, , , 1)
.Caption = "Form " & name
.OnAction = "Show" & name
.FaceId = 9895
End With
End Sub

Sub ResetPopupMenu()
Application.CommandBars("Cell").Reset
End Sub
[/GPECODE]

3. codde Sheet S01:
[GPECODE=vb]
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Run "ResetPopupMenu"

If Not Intersect(Range("K9:K12000"), Target) Is Nothing Then
Run "BuildPopupMenu", "DMHH"
ElseIf Not Intersect(Range("AH9:AH12000"), Target) Is Nothing Then
Run "BuildPopupMenu", "DMDG"
End If
End Sub

Private Sub Worksheet_Deactivate()
Run "ResetPopupMenu"
End Sub
[/GPECODE]
-------------
Các macro phải là Public để có thể gọi từ các mô-đun khác
Mà thay cho "Run macro" thì sao không "Call sub"?

 

[Hong.Van]

Các macro phải là Public để có thể gọi từ các mô-đun khác
Mà thay cho "Run macro" thì sao không "Call sub"?

Em có biết nhiều về code đâu! đụng đâu thử đó nên nó như vậy!
Em cảm ơn các anh.

 

[ndu96081631]

Làm thử cách khác (nhưng tương tự với cách của anh siwtom)
1> Trong Module

Sub ShowDMHH()
  FormDMMH.Show
End Sub

Sub ShowDMDG()
  FormDMDG.Show
End Sub

Sub BuildPopupMenu(ByVal Caption As String, _
                   ByVal Action As String, _
                   ByVal FaceId As Long)
  On Error Resume Next
  ResetPopupMenu
  With Application.CommandBars("Cell").Controls.Add(1, , , 1, True)
    .Caption = Caption
    .OnAction = Action
    .FaceId = FaceId
  End With
End Sub

Sub ResetPopupMenu()
  On Error Resume Next
  Application.CommandBars("Cell").Reset
End Sub

2> Trong Sheet TH:

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  On Error GoTo ExitSub
  ResetPopupMenu
  If Target.Count = 1 Then
    If Not Intersect(Range("K9:K12000"), Target) Is Nothing Then
      BuildPopupMenu "Form DMHH", "ShowDMHH", 9895
    ElseIf Not Intersect(Range("AH9:AH12000"), Target) Is Nothing Then
      BuildPopupMenu "Form DMDG", "ShowDMDG", 9895
    End If
  End If
ExitSub:
End Sub

Private Sub Worksheet_Deactivate()
  ResetPopupMenu
End Sub

----------------
Xin nói thêm: Tôi thấy 2 form gần như tương tự nhau về cấu trúc, vậy sao bạn không cố gắng gộp chúng thành một?

 

[Hong.Van]

GIÚP SỬA CODE ĐỂ FORM HIỆN Ở CỘT G HOẶC AG CỦA SHEET "TH"
-------------------------------------------------------------------
Hiện em có Form DMMaKH, Form này lấy dữ liệu từ 2 cột BF và BG của Sheet MA
Em muốn Muốn Form này sẽ hiện tại cột G HOẶC cột AG của Sheet TH, Form hiện 2 cột nhưng chỉ lấy cột Mã KH trong Form thôi
----------------
Hiện nay chỉ có cột G là lấy được số liệu từ Form, còn cột AG thì em chưa làm được! Vui lòng giúp em sửa code!
Code trong Sheet TH

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Run "ResetPopupMenu"
    If Not Intersect(Range("G9:G12000"), Target) Is Nothing Then
        Run "BuildPopupMenu", "DMMaKH"
    ElseIf Not Intersect(Range("AG9:AG12000"), Target) Is Nothing Then
        Run "BuildPopupMenu", "DMMaKH"
    End If
End Sub


Private Sub Worksheet_Deactivate()
    Run "ResetPopupMenu"
End Sub

Code trong Module

Sub ShowDMMaKH()
On Error Resume Next
    If ActiveSheet.name = "TH" And ActiveCell.Row > 8 And _
        ActiveCell.Row < 12000 And ActiveCell.Column = 33 Then
        FormDMMaKH.Show 1
    End If:
    If ActiveSheet.name = "TH" And ActiveCell.Row > 8 And _
        ActiveCell.Row < 12000 And ActiveCell.Column = 7 Then
        FormDMMaKH.Show 1
    End If:
End Sub
 
Sub BuildPopupMenu(ByVal name As String)
    With Application.CommandBars("Cell").Controls.Add(1, , , 1)
        .Caption = "Form " & name
        .OnAction = "Show" & name
        .FaceId = 9895
    End With
End Sub
 
Sub ResetPopupMenu()
    Application.CommandBars("Cell").Reset
End Sub

Code trong This Workbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  ResetPopupMenu
End Sub
Private Sub Workbook_Deactivate()
  ResetPopupMenu
End Sub

Code trong Form

Private Sub CB_Tim_Click()    With Application
        .ScreenUpdating = False
        On Error Resume Next
    End With
    Dim endR As Long, i As Long, s As Long, k As Long
    Dim arr(), arrKQ()
    Dim MaHHTim As String
    With Sheets("MA")
        endR = .Cells(65000, 59).End(xlUp).Row
        arr = .Range(.Cells(10, 58), .Cells(endR, 59)).Value
    End With
    ReDim arrKQ(1 To endR, 1 To 3)
    s = 0
    MaHHTim = Me.NhomHang.Value
    For i = 1 To UBound(arr)
        If InStr(UCase(arr(i, 1)), UCase(MaHHTim)) Then
            s = s + 1
            For k = 1 To 3
                arrKQ(s, k) = arr(i, k)
            Next k
        End If
        If InStr(UCase(arr(i, 2)), UCase(MaHHTim)) Then
            s = s + 1
            For k = 1 To 3
                arrKQ(s, k) = arr(i, k)
            Next k
        End If
    Next i
    If s = 0 Then
        MsgBox "No Ma"
        Me.NhomHang.SetFocus
        With Me.MHList
            .ColumnCount = 5
            .List = arr
        End With
    End If
    With Me.MHList
        .Clear
        .ColumnCount = 5
        .List = arrKQ
    End With
    With Application
        .ScreenUpdating = False
    End With
    Erase arr(), arrKQ()
End Sub
Private Sub Nhap_Click()
    On Error Resume Next
    Dim j&, i&, SelectItem
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    j = ActiveCell.Row
    If ActiveSheet.name = "TH" Then
        ActiveSheet.Select
        For i = 0 To MHList.ListCount - 1
            If MHList.Selected(i) Then
                [COLOR=#ff0000]Cells(j, 33) = MHList.List(i)
                'Cells(j, 7) = MHList.List(i)[/COLOR]
                'Cells(j, 4) = MHList.List(i, 2)
                j = j + 1
                SelectItem = 1
            End If
        Next
    End If
    If SelectItem = 0 Then
        MsgBox "Ban da khong chon ten nao trong danh sach !"
    End If
    Unload Me
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub


Private Sub NhomHang_AfterUpdate()
    CB_Tim.SetFocus
End Sub
Private Sub Thoat_Click()
    Unload Me
End Sub
Private Sub UserForm_Initialize()
    Dim endR As Long
    Dim arr()
    With Sheets("MA")
        endR = .Cells(65000, 59).End(xlUp).Row
        arr = .Range(.Cells(10, 58), .Cells(endR, 59)).Value
    End With
    With Me.MHList
        .ColumnCount = 2
        .List = arr
    End With
    'MHList.Selected(0) = True
    NhomHang.SetFocus
    Erase arr
End Sub

Có thể fải xử lý chỗ chữ màu đỏ, nhưng em chưa biết xử lý thế nào!
Em cảm ơn!