Nhờ trợ giúp code VBA DOUBLE Click cell

[tinhcodon]

Mình có tìm được 1file Excel Thống kê dự án và nhiệm vụ cần làm trên mạng. Trong đó có đoạn code double click ở sheet1 để xem dữ liệu được autoFilter bên sheet 2. nhưng khi double click vào cell thì không chạy được. Mong anh chị em xem giúp. Mặc dù mình đã lưu file cho phép chạy macro rồi.

 

[batman1]

Trong Sheet1 có code

If Intersect(Target.EntireRow, [Projects[Project]]) Is Nothing Then Exit Sub

Trong Sheet2 có

BooleanCellDoubleClick Target, [Tasks[[Done]]], Cancel

Đoán mò: Tác giả của tập tin có name Projects và Tasks, và cột B trong Sheet1 có tiêu đề là Project, cột F trong sheet2 có tiêu đề là Done. Bây giờ "ông nào đó" tải về và đổi tên thành name Các_dự_án và Nhiệm_vụ, và tiêu đề 2 cột là Dự_án và "Đã thực hiện".

Không còn Projects, Tasks, Project, và Done thì ắt 2 dòng code ở trên sẽ có lỗi. Nhưng do trước đó có On Error Resume Next nên "ông nào đó" không ý thức được là có lỗi.

Tốt nhất là phục hồi các tên cũ hoặc sửa như sau.

Lưu ý: Tôi chỉ sửa để khỏi hết lỗi, tôi không xét chuẩn, không xét tối ưu, không xét gì thêm.

Trong Sheet1

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strCellVal As String
Dim i As Long

    On Error Resume Next
   
    If Intersect(Target.EntireRow, Sheet1.Range("B4:B7")) Is Nothing Then Exit Sub
    If Target.Cells.Count <> 1 Then Exit Sub
   
    strCellVal = ActiveCell.Value
   
    With Sheet2
        .ListObjects(1).Range.AutoFilter 3, Criteria1:=Intersect(Target.EntireRow, Sheet1.Range("B4:B7"))
        .Activate
        i = .ListObjects(1).Range.Columns(1).SpecialCells(xlCellTypeVisible).Count
     If i = 1 Then
        .ListObjects(1).Range.End(xlDown).Offset(1, 2).Value = strCellVal
     End If
        .[A1].Select
    End With
       
    Cancel = True

End Sub

Trong Sheet2

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    On Error Resume Next
   
    With Application
        .Cursor = xlNorthwestArrow
        BooleanCellDoubleClick Target, Sheet2.Range("F4:F21"), Cancel
        .Cursor = xlDefault
    End With

End Sub

 

[tinhcodon]

Trong Sheet1 có code

Trong Sheet2 có


Đoán mò: Tác giả của tập tin có name Projects và Tasks, và cột B trong Sheet1 có tiêu đề là Project, cột F trong sheet2 có tiêu đề là Done. Bây giờ "ông nào đó" tải về và đổi tên thành name Các_dự_án và Nhiệm_vụ, và tiêu đề 2 cột là Dự_án và "Đã thực hiện".

Không còn Projects, Tasks, Project, và Done thì ắt 2 dòng code ở trên sẽ có lỗi. Nhưng do trước đó có On Error Resume Next nên "ông nào đó" không ý thức được là có lỗi.

Tốt nhất là phục hồi các tên cũ hoặc sửa như sau.

Lưu ý: Tôi chỉ sửa để khỏi hết lỗi, tôi không xét chuẩn, không xét tối ưu, không xét gì thêm.

Trong Sheet1

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strCellVal As String
Dim i As Long

    On Error Resume Next
  
    If Intersect(Target.EntireRow, Sheet1.Range("B4:B7")) Is Nothing Then Exit Sub
    If Target.Cells.Count <> 1 Then Exit Sub
  
    strCellVal = ActiveCell.Value
  
    With Sheet2
        .ListObjects(1).Range.AutoFilter 3, Criteria1:=Intersect(Target.EntireRow, Sheet1.Range("B4:B7"))
        .Activate
        i = .ListObjects(1).Range.Columns(1).SpecialCells(xlCellTypeVisible).Count
     If i = 1 Then
        .ListObjects(1).Range.End(xlDown).Offset(1, 2).Value = strCellVal
     End If
        .[A1].Select
    End With
      
    Cancel = True

End Sub

Trong Sheet2

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    On Error Resume Next
  
    With Application
        .Cursor = xlNorthwestArrow
        BooleanCellDoubleClick Target, Sheet2.Range("F4:F21"), Cancel
        .Cursor = xlDefault
    End With

End Sub

Ôi, cảm ơn bro! Chạy được rồi ơi. Hèn gì em cứ nghĩ cái project là gì mãi mà không hiểu. (Em gà mờ, tự mò và vọc excel. Có hứng thú với excel từ khi biết đến diễn đàn này!)

 

[tinhcodon]

Code trong sheet2 không chạy được ạ!

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) On Error Resume Next With Application .Cursor = xlNorthwestArrow BooleanCellDoubleClick Target, Sheet2.Range("F4:F21"), Cancel .Cursor = xlDefault End With End Sub