Prevent user from delete worksheet

method 1:

Private Sub Worksheet_Activate()

Dim Ctrl As Office.CommandBarControl

For Each Ctrl In Application.CommandBars.FindControls(ID:=847)

Ctrl.Enabled = False

Next Ctrl

End Sub

Private Sub Worksheet_Deactivate()

Dim Ctrl As Office.CommandBarControl

For Each Ctrl In Application.CommandBars.FindControls(ID:=847)

Ctrl.Enabled = True

Next Ctrl

End Sub

----------------------------------------------------------------------------------------------------------------

Method 2:

Option Explicit

Private Sub Workbook_Activate()

Call Workbook_SheetActivate(ActiveSheet)

End Sub

Private Sub Workbook_Deactivate()

Call Indel

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets

If ActiveSheet.Name = ("Data") _

Or ActiveSheet.Name = ("Query") _

Or ActiveSheet.Name = ("Sheet1") Then

Outdel

Else

Indel

End If

Next ws

End Sub

Private Sub Outdel()

Dim Ctrl As Office.CommandBarControl

For Each Ctrl In Application.CommandBars.FindControls(ID:=847)

Ctrl.Enabled = False

Next Ctrl

End Sub

Private Sub Indel()

Dim Ctrl As Office.CommandBarControl

For Each Ctrl In Application.CommandBars.FindControls(ID:=847)

Ctrl.Enabled = True

Next Ctrl

End Sub

----------------------------------------------------------------------------------------------------------------

Method 3:

Private Sub Worksheet_Activate()

Dim CB As CommandBar

Dim Ctrl As CommandBarControl

For Each CB In Application.CommandBars

Set Ctrl = CB.FindControl(ID:=847, recursive:=True)

If Not Ctrl Is Nothing Then

Ctrl.OnAction = "RefuseToDelete"

Ctrl.State = msoButtonUp

End If

Next

End Sub

Private Sub Worksheet_Deactivate()

Dim CB As CommandBar

Dim Ctrl As CommandBarControl

For Each CB In Application.CommandBars

Set Ctrl = CB.FindControl(ID:=847, recursive:=True)

If Not Ctrl Is Nothing Then Ctrl.OnAction = ""

Next

End Sub

Private Sub ResetDelete()

Dim CB As CommandBar

Dim Ctrl As CommandBarControl

For Each CB In Application.CommandBars

Set Ctrl = CB.FindControl(ID:=847, recursive:=True)

If Not Ctrl Is Nothing Then

Ctrl.Reset

Next CB

End Sub

'put in standard module

Public Sub RefuseToDelete()

MsgBox "This worksheet should not be deleted!", _

Buttons:=vbExclamation, _

Title:="Cannot Deleteworksheet!"

End Sub

Add-ins tab of the Ribbon

Sub CreateMenu()

' creates a new menu.

' can also be used to create commandbarbuttons

' may be automatically executed from an Auto_Open macro or a Workbook_Open eventmacro

Dim cbMenu As CommandBarControl, cbSubMenu As CommandBarControl

RemoveMenu ' delete the menu if it already exists

' create a new menu on an existing commandbar (the next 6 lines)

Set cbMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True)

With cbMenu

.Caption = "&My menu"

.Tag = "MyTag"

.BeginGroup = False

End With

' alternatively, add to an existing menu (use the next line instead of the previous 6 lines)

'Set cbMenu = Application.CommandBars.FindControl(, 30007) ' Tools-menu

If cbMenu Is Nothing Then Exit Sub ' didn't find the menu...

' add menuitem to menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Menu Item1"

.OnAction = ThisWorkbook.Name & "!TestMacro"

End With

' add menuitem to menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Menu Item2"

.OnAction = ThisWorkbook.Name & "!TestMacro"

End With

' add a submenu

Set cbSubMenu = cbMenu.Controls.Add(msoControlPopup, 1, , , True)

With cbSubMenu

.Caption = "&Submenu1"

.Tag = "SubMenu1"

.BeginGroup = True

End With

' add menuitem to submenu (or buttons to a commandbar)

With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Submenu Item1"

.OnAction = ThisWorkbook.Name & "!TestMacro"

.Style = msoButtonIconAndCaption

.FaceId = 71

.State = msoButtonDown ' or msoButtonUp

End With

' add menuitem to submenu (or buttons to a commandbar)

With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Submenu Item2"

.OnAction = ThisWorkbook.Name & "!TestMacro"

.Style = msoButtonIconAndCaption

.FaceId = 72

.Enabled = False ' or True

End With

' add a submenu to the submenu

Set cbSubMenu = cbSubMenu.Controls.Add(msoControlPopup, 1, , , True)

With cbSubMenu

.Caption = "&Submenu2"

.Tag = "SubMenu2"

.BeginGroup = True

End With

' add menuitem to submenu submenu

With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Submenu Item1"

.OnAction = ThisWorkbook.Name & "!TestMacro"

.Style = msoButtonIconAndCaption

.FaceId = 71

.State = msoButtonDown ' or msoButtonUp

End With

' add menuitem to submenu submenu

With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Submenu Item2"

.OnAction = ThisWorkbook.Name & "!TestMacro"

.Style = msoButtonIconAndCaption

.FaceId = 72

.Enabled = False ' or True

End With

' add menuitem to menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Remove this menu"

.OnAction = ThisWorkbook.Name & "!RemoveMenu"

.Style = msoButtonIconAndCaption

.FaceId = 463

.BeginGroup = True

End With

Set cbSubMenu = Nothing

Set cbMenu = Nothing

End Sub

Sub RemoveMenu()

' may be automatically executed from an Workbook_Close macro or

' a Workbook_BeforeClose eventmacro

DeleteCustomCommandBarControl "MyTag" ' deletes the new menu

End Sub

Private Sub DeleteCustomCommandBarControl(CustomControlTag As String)

' deletes ALL occurences of commandbar controls with a tag = CustomControlTag

On Error Resume Next

Do

Application.CommandBars.FindControl(, , CustomControlTag, False).Delete

Loop Until _

Application.CommandBars.FindControl(, , CustomControlTag, False) Is Nothing

On Error GoTo 0

End Sub

Sub TestMacro()

' used by the menuitems created by the CreateMenu macro

MsgBox "This would run your macro!", vbInformation, ThisWorkbook.Name

End Sub

find word funtion for macro vba

Option Explicit

Sub Format_Characters_In_Found_Cell()

Dim Found As Range, x As String, FoundFirst As Range

x = "over"

On Error Resume Next

Set Found = Cells.Find(what:=x, LookIn:=xlValues, LookAt:=xlPart)

If Not Found Is Nothing Then

Set FoundFirst = Found

Do

'Format from "x" to the end of the cell

Found.Characters(Start:=InStr(1, Found.Text, x), Length:=Len(Found)).Font.ColorIndex = 5

Set Found = Cells.FindNext(Found)

Loop Until FoundFirst.Address = Found.Address

Else

MsgBox x & " could not be found.", , " "

End If

End Sub

---------------------

What:="*a*b*" // provided a start 1st follow by keyword b

---------------------------------------------------------------------------------------------

References

http://www.excel-vba-easy.com/vba-programming-string-manipulation.html

http://www.pcreview.co.uk/forums/find-function-t2215904.html

http://www.mrexcel.com/forum/showthread.php?t=576407

search text in excel cell

myint=instr(1,activecell.value,"Abc")
which is going to return a number to where "Abc" starts

if myint > 0
text found.
----------------------------------------------------------------------
Function TextSearch(ByVal strSearchFor, ByVal Target As Variant) As Boolean
Dim OneCell As Range

TextSearch = False
If TypeName(Target) = "Range" Then
For Each OneCell In Target
If InStr(1, OneCell.Text, strSearchFor, vbTextCompare) > 0 Then
TextSearch = True
Exit For
End if
Next OneCell
ElseIf TypeName(Target) = "String" Then
If InStr(1, Target, strSearchFor, vbTextCompare) > 0 Then TextSearch = True
End If

End Function


------------------------------------------------------------------------------

Reference:

1. http://www.eng-tips.com/viewthread.cfm?qid=127459

http://www.ozgrid.com/forum/showthread.php?t=115687


Option Explicit

Sub Bold1stWord()
Dim rCell As Range

With Selection
.Cells.Copy
.Cells.PasteSpecial xlValues
Application.CutCopyMode = False
For Each rCell In .Cells
rCell.Characters(1, InStr(1, rCell, ":") - 1).Font.Bold = True
Next rCell
End With
End Sub

extract 1 word in cell for macro vba

http://www.teachexcel.com/free-excel-macros/m-138,udf-get-first-word-cell-excel-free-macro.html
Function GETFIRSTWORD(Text As String, Optional Separator As Variant)

Dim firstword As String

If IsMissing(Separator) Then
Separator = " "
End If
firstword = Left(Text, InStr(1, Text, Separator, vbTextCompare))
GETFIRSTWORD = Replace(firstword, Separator, "")

End Function

Excel Macro, VB

http://spreadsheetpage.com/index.php/file/C36/P20/
http://spreadsheetpage.com/index.php/files
- spreadsheet page with different macro and VB program, userform

http://spreadsheetpage.com/index.php/tip/C29

http://spreadsheetpage.com/index.php/tip/displaying_a_menu_of_worksheets_to_print/

tips
http://spreadsheetpage.com/index.php/tips