vba-禁止重命名sheet

admin

1. Dim aa, bb
   
2. 
   
3. Private Sub Workbook_Open()
   
4. 
   
5. aa = ActiveSheet.Name
   
6. 
   
7. bb = ActiveSheet.Index
   
8. 
   
9. End Sub
   
10. 
    
11. Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    
12. 
    
13. aa = ActiveSheet.Name
    
14. 
    
15. bb = ActiveSheet.Index
    
16. 
    
17. End Sub
    
18. 
    
19. Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    
20. 
    
21. On Error Resume Next
    
22. 
    
23. If Sheets(bb).Name <> aa Then Sheets(bb).Name = aa
    
24. 
    
25. End Sub
    
26. 
    
27. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object,
    
28. 
    
29. ByVal Target As Range)
    
30. 
    
31. On Error Resume Next
    
32. 
    
33. If Sheets(bb).Name <> aa Then Sheets(bb).Name = aa
    
34. 
    
35. End Sub

复制代码

建立一个搜索

1. Sub 查找指定值()
   
2.     Dim result As String, str1 As String, str2 As String
   
3.     Dim c As Range
   
4.     result = Application.InputBox(prompt:="请输入要查找的值：", Title:="查找", Type:=2)
   
5.     If result = "False" Or result = "" Then Exit Sub
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     With ActiveSheet.Cells
   
9.         Set c = .Find(result, , , xlWhole, xlByColumns, xlNext, False)
   
10.         If Not c Is Nothing Then
    
11.             str1 = c.Address
    
12.             Do
    
13.                 c.Interior.ColorIndex = 4 '加亮显示
    
14.                 str2 = str2 & c.Address & vbCrLf
    
15.                 Set c = .FindNext(c)
    
16.             Loop While Not c Is Nothing And c.Address <> str1
    
17.         End If
    
18.     End With
    
19.     MsgBox "查找到指定数据在以下单元格中：" & vbCrLf & vbCrLf _
    
20.         & str2, vbInformation + vbOKOnly, "查找结果"
    
21.     Application.ScreenUpdating = True
    
22.     Application.DisplayAlerts = True
    
23. End Sub

复制代码