## Wednesday, 24 December 2014

### How to Find the Count of Instances or Occurrences of a Character or Substring in a String

Excel Function to Count the Number of Instances of Character or Substring in a String
In Excel we can find the Count of Instances or Occurrences of a Character or Substring in a String using the following formula :

=LEN(A1)-LEN(SUBSTITUTE(A1,";",""))

Example :

Suppose we have a String in a Cell "A1" which contains the character Semicolon  ";"

Now if we want to find how many Semicolons are there in that string , we can find using the below formula :

=LEN(A1)-LEN(SUBSTITUTE(A1,";",""))

Please observe the following examples for better understanding :

 String Count of Char/Sub String Formula Result ABC;DEF,@@;#@@;JKLM@@;DEF =LEN(A2)-LEN(SUBSTITUTE(A2,";","")) 4 ABC;DEF,@@;#@@;JKLM@@;DEF =LEN(A3)-LEN(SUBSTITUTE(A3,"@@","1")) 3 ABC;DEF,@@;#@@;JKLM@@;DEF =LEN(A4)-LEN(SUBSTITUTE(A4,"DEF","12")) 2 ABC;DEF,@@;#@@;JKLM@@;DEF =LEN(A5)-LEN(SUBSTITUTE(A5,"JKLM","123")) 1

Tip :
If you want to find the Instance of a Substring(Eg: ",") of length 1 character , we have to use No space ("") in above SUBSTITUTE Function.

In the Same way , If you want to find the Instance of a Substring(Eg: abc) of length 3 characters , we have to use 2 spaces("  ") or a string of length 2 characters(Eg: 12) in above SUBSTITUTE Function.

Similarly ,If you want to find the Instance of a Substring(Eg: abcd) of length 4 characters , we have to use 3 spaces("   ") or a string of length 3 characters(Eg: 123) in above SUBSTITUTE Function.

Thanks ,
TAMATAM

## Tuesday, 9 December 2014

### How to disable Cut,Copy,Paste and Delete Keys In Excel VBA

Excel VBA Application.Onkey to Disable Cut,Copy,Paste and Delete Keys
By using the Application.Onkey we can disable a particular Key or key combination or run a macro when you use a particular key or key combination.

The Key argument can specify any single key combined with ALT, CTRL, or SHIFT, or any combination of these keys. Each key is represented by one or more characters, such as the  "^ {c}" for Key Combination "Ctrl+C", or "{TAB}" for the TAB key etc.

You can assigns "YourMacroName" to the key sequence CTRL+SHIFT+ENTER , as follows
Application.OnKey "^+{ENTER}", "YourMacroName"

Symbols used in Key Combinations:

Shift key = "+" (plus sign)
Ctrl key = "^" (caret)

Alt key = "%" (percent sign)

Example-I :
The following Macro is used to disable the Cut,Copy,Paste and Delete Key in Excel.
You can call this Macro in Worksheet or Workbook event to Disable or Enable Keys as per your requirement.

Sub Disable_Enable_CutCopyDel_Keys()

To Disable Copy,Cut,Past and Delete Keys
Application.EnableEvents = False

Application.OnKey "^{c}", ""              -----------------'Copy
Application.OnKey "^{x}", ""              -----------------'Cut
Application.OnKey "^{v}", ""              -----------------'Paste
Application.OnKey "{DEL}", ""

To Disable Cell Drag And Drop In Excel
Application.CellDragAndDrop = False

To Enable back the Copy,Cut,Past and Delete Keys

Application.EnableEvents = True

Application.OnKey "^{c}"              -----------------'Copy
Application.OnKey "^{x}"              -----------------'Cut
Application.OnKey "^{v}"              -----------------'Paste
Application.OnKey "{DEL}"

To Enable back Cell Drag And Drop In Excel
Application.CellDragAndDrop = True

End Sub

Example-II :
The following Macro is used to disable the Cut,Copy options in mouse Right Click options.
You can call this Macro in Worksheet or Workbook event to Disable or Enable options as per your requirement.

Sub DisEnable_CutCopy_on_Mouse_Right_Click()

Dim Dis_Ctrl As Office.CommandBarControl

'Disable Cut Option from Mouse Right Click
For Each Dis_Ctrl In Application.CommandBars.FindControls(ID:=21)
Dis_Ctrl.Enabled = False
Next Dis_Ctrl

'Disable Copy Option from Mouse Right Click
For Each Dis_Ctrl In Application.CommandBars.FindControls(ID:=19)
Dis_Ctrl.Enabled = False
Next Dis_Ctrl

'Enable Cut Option from Mouse Right Click
For Each Dis_Ctrl In Application.CommandBars.FindControls(ID:=21)
Dis_Ctrl.Enabled = True
Next Dis_Ctrl

'Enable Copy Option from Mouse Right Click
For Each Dis_Ctrl In Application.CommandBars.FindControls(ID:=19)
Dis_Ctrl.Enabled = True
Next Dis_Ctrl

End Sub

Thanks,
TAMATAM

## Tuesday, 2 December 2014

### How to Copy the Files from Different Source Locations or Paths to Multiple Destinations

Macro to Copy the Files from Different Locations or Paths to Multiple Destinations
Sub Copy_SourceFiles_2_Destination()
Dim SrcFileName As String
Dim SrcFolderPath As String
Dim SrcFilExt As String
Dim SourceFile 'As String
Dim TargetFolderPath As String
Dim WS As Worksheet
Dim FSO As Object

'The Sheet in which we specify the Files details to Copy
Set WS = ThisWorkbook.Sheets("Bridge_Files_Trans")

Set FSO = CreateObject("Scripting.FileSystemObject")

For X = 2 To 100
If WS.Cells(X, 2) = "" Then Exit For

SrcFileName = WS.Cells(X, 2)
SrcFilExt = WS.Cells(X, 3)
SrcFolderPath = WS.Cells(X, 4)

'Setting the Source Folder path end with "\"
If Right(SrcFolderPath, 1) <> "\" Then
SrcFolderPath = SrcFolderPath & "\"
End If

'Checking the Source Folder Exists or Not
If FSO.FolderExists(SrcFolderPath) = False Then
WS.Cells(X, 6) = "Failed"
GoTo Nxt:
End If

'Source File Name
SourceFile = SrcFolderPath & SrcFileName & SrcFilExt

'Checking the Source File Existence
If FSO.FileExists(SourceFile) = False Then
WS.Cells(X, 6) = "Failed"
GoTo Nxt:
End If

'Source Folder Path
TargetFolderPath = WS.Cells(X, 5)

'Setting the Target Folder path end with "\"
If Right(TargetFolderPath, 1) <> "\" Then
TargetFolderPath = TargetFolderPath & "\"
End If

'Checking the Target Folder Exists or Not
If FSO.FolderExists(TargetFolderPath) = False Then
WS.Cells(X, 6) = "Failed"
GoTo Nxt:
End If

'Copying the Files from Source location to Destination
FSO.CopyFile SourceFile, TargetFolderPath

'Changing the Source File Name in the Destination after Copy.
TgtFileName = TargetFolderPath & SrcFileName

Name TgtFileName & SrcFilExt As TgtFileName & " - " & WS.Cells(2, 7) & SrcFilExt
WS.Cells(X, 6) = "Success"

Nxt:

Next X

MsgBox "All Source Files SuccessFull Copied to Destination Folders", vbOKOnly, "Job Done"

Set WS = Nothing
Set FSO = Nothing

End Sub

Thanks,
TAMATAM

## Tuesday, 25 November 2014

### How to Create Table of Contents and Index for a Report in Excel with VBA Macro

The following Macro will create an Index Tab called "MY_INDEX" and in this Tab it will create the Table of Contents with list of Sheet names available in ThisWorkbook with Hyperlinks directing you to respective Sheet .
Next in each Tab except <Index Tab> it will create the <Back to Index> button with Hyperlink directing you to <Index Tab>.
Dim K As Long
On Error Resume Next

'Deleting an old Index if it already exist with the Name<MY_INDEX>
ThisWorkbook.Sheets("MY_INDEX").Delete
On Error GoTo 0
'Adding an Index tab in ThisWorkbook with the Name<MY_INDEX>
ActiveSheet.Name = "MY_INDEX"
ThisWorkbook.Sheets("MY_INDEX").Cells(1, 1) = "INDEX"
'Adding and formatting the Index title in <MY_INDEX> Tab
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
End With

With Selection.Font
.ThemeColor = xlThemeColorDark1
End With

Selection.Font.Bold = True
With Selection.Font
.Name = "Calibri"
.Size = 14
.ThemeColor = xlThemeColorDark1
.ThemeFont = xlThemeFontMinor
End With

ActiveCell.ColumnWidth = 35
'Looping through other than <MY_INDEX> tab to add <Back to Index> Button.

For K = 2 To Sheets.Count
ThisWorkbook.Sheets("MY_INDEX").Activate
ActiveSheet.Cells(K, 1).Select
SubAddress:="'" & Sheets(K).Name & "'!A1", TextToDisplay:=Sheets(K).Name

If Sheets(K).Name = "INDEX" Then GoTo NxtSht
Sheets(K).Activate
ActiveSheet.Rows("1:1").RowHeight = 30.75
ActiveSheet.Columns("A:A").ColumnWidth = 16.29
ActiveSheet.Range("A1").Select

'Adding < Back to Index > button in Other tabs
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset31
Selection.Placement = xlFreeFloating
'Renaming <Shape Name> and Storing the Name in a Variable
Selection.ShapeRange.Name = "Back2Index"
Z = Selection.ShapeRange.Name
'Adding the Text as <Back to Index> in the Shape
Selection.ShapeRange(Z).TextFrame2.TextRange.Characters.Text = "Back to Index"

With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 13). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignLeft
End With

'Formatting the Shape Color Themes
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 13).Font
.Bold = msoTrue
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
ActiveSheet.Shapes.Range(Array(Z)).Select
SubAddress:="'" & Sheets(1).Name & "'!A1", TextToDisplay:=""
ActiveSheet.Range("A2").Select

NxtSht:

Next K

ThisWorkbook.Sheets("MY_INDEX").Activate
ActiveSheet.Cells(1, 1).Select
End Sub
-------------------------------------------------------------------------------
The above Macro will create an Index Tab with Report Index ( Hyper links to each Tab of the Report) as follows :

and in each tab of the report , a <Back to Index> button will be created as follows :

## Saturday, 22 November 2014

### How to Create a Backup for Active Workbook with Current Date with Excel Macro

Excel VBA Macro to Create a Back up for Active Workbook with Current Date in Same Location.
Sub Create_Backup()
ActiveWorkbook.SaveCopyAs _
Filename:=ActiveWorkbook.Path & "\" & "BackUp" & "_" & _
Format(Date, "MM-DD-YY") & "_" & ActiveWorkbook.Name
End Sub

In the Same way we can Create a Back up for ThisWorkbook with Current Date as follows :

Sub Create_Backup()
ThisWorkbook.SaveCopyAs _
Filename:=ThisWorkbook.Path & "\" & "BackUp" & "_" & _
Format(Date, "MM-DD-YY") & "_" & ThisWorkbook.Name
End Sub

Tips :
If you want to Save the ActiveWorkbook of different format(97-2003 format) to a desired format(2007 format), use the following file format Codes.

51 = xlOpenXMLWorkbook (2007-2013, xlsx)
52 = xlOpenXMLWorkbookMacroEnabled (Macro Enabled Format in 2007-2013, xlsm)
50 = xlExcel12 (Excel Binary Format in 2007-2013 , xlsb)
56 = xlExcel8 (97-2003 Format to Excel 2007-2013, xls)

Ex:

Note:
It is always better to use the FileFormat Code Numbers instead of the Defined Constants in the code so that Macro will Compile OK .

Ex:
Excel 97-2003 may won't understand what is the < xlOpenXMLWorkbookMacroEnabled> Constant is.

Help :
Active Workbook means the Workbook which is Currently Active / on which we are currently working.

This Workbook means the Workbook in which we are writing the Macro code.

Sample View of BackUp :

## Friday, 21 November 2014

### How to Store and Retrieve the Values in an Array with Excel VBA Macro

Excel VBA Macro to  Store Values into an Array and Retrieve the Values from an Array
Suppose we have the Months as shown below , which we want to store in an Array

Sub Strore_Retrieve_Array()
Dim My_Array() As String
Dim WS As Worksheet

Set WS = ActiveSheet

'<< Storing the Values in an Array >>
For X = 2 To 13

ReDim Preserve My_Array(X - 2) ' Storing from Index(0)
My_Array(X - 2) = Cells(X, 1).Value

Next X

'<< Retrieving the Values from an Array >>
For K = LBound(My_Array()) To UBound(My_Array())

Msgbox My_Array(K)
'<< Define your own condition here >>
If My_Array(K) = "Jul" Then
GoTo Tamatam:
End If

Next K

Tamatam:
MsgBox "Desired Value << Jul >> Found At Array Index" & "<< " & K & " >>"
End Sub

Thanks,
TAMATAM

### How to Copy and Print each Named Range on a Power Point Presentation Slides with Excel VBA Macro

Macro to Copy and Print each Named Range on a Power Point Presentation Slides
The following Macro is designed to Print the Named Ranges whose names like PPT_01,PPT_02,PPT_03........PPPT_XX., of This Workbook on Power Point Presentation Slides of specified PowerPoint Template Deck which is Pre-designed.

----------------------------------------------------------------------------------------------------------------
Sub Gen_PPT_04_MyNamedRanges()
Dim New_PPT As PowerPoint.Presentation
Dim PPT_Slide As PowerPoint.Slide
Dim Exl_WB As Object
Dim PPT_File As String
Dim Slides_Count As Integer
Dim PPT_No As Integer
Dim Rng As Object
Dim Rng_Name As String
Dim CopyRange As Range

K = 0

' << An Existing PPT Presentation Deck with Defined Slides >>
PPT_File = ThisWorkbook.Sheets("C_PANEL").Range("B2").Value

' << Saving Path of Output PPT Presentation and its Name >>
Save_Path = ThisWorkbook.Sheets("C_PANEL").Range("B3").Value
OutPut_Name = ThisWorkbook.Sheets("C_PANEL").Range("B1").Value

Set New_PowerPoint = Nothing
On Error Resume Next
Set New_PowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'<< Check whether a PPT Application is Open if open Close and open a New Application >>
If New_PowerPoint Is Nothing Then
Set New_PowerPoint = New PowerPoint.Application
New_PowerPoint.Visible = msoCTrue
Else
New_PowerPoint.Quit
Set New_PowerPoint = New PowerPoint.Application
New_PowerPoint.Visible = msoCTrue
On Error GoTo 0
End If

Set Exl_WB = ThisWorkbook

Set New_PPT = New_PowerPoint.Presentations.Open(Filename:=PPT_File)

' << Counting the No.of Slides in the Active PPT File >>
Slides_Count = New_PowerPoint.ActivePresentation.Slides.Count

' << Looping through each Named Range in Workbook >>

For Each Rng In Exl_WB.Names
Rng_Name = Rng.Name

'<<Checking the Named Range name should be like 'PPT_01',PPT_02... and it should not contain '!'  >>.
If InStr(1, Rng_Name, "PPT") > 0 And InStr(1, Rng_Name, "!") = 0 Then
PPT_No = Int(Right(Rng_Name, 2))

'<< Adjust back the Slide Number on Which we Print Named Range when it More than Slides_Count >>'
'<< This one type of logic used in different scenario >>
If PPT_No > Slides_Count Then
K = K + 1
PPT_No = 15+ K ' Change as per your requirement
End If
'<< --------------------- >>'

New_PowerPoint.ActiveWindow.View.GotoSlide (PPT_No)
Set PPT_Slide = New_PowerPoint.ActivePresentation.Slides(PPT_No)

' << Storing the Range Reference in a Variable >>
Rng_Ref = Exl_WB.Names(Rng_Name).Value

'<< Checking whether there is any Ref# error in the Range Refereed.>>
If InStr(1, Rng_Ref, "REF") = 0 Then
'<< Storing Named Range in a variable >>
Set CopyRange = Exl_WB.Names(Rng_Name).RefersToRange

'<<Activating the Active Named Range Sheet and Copying that Range >>
Rng_Sht_Name = Exl_WB.Names(Rng_Name).RefersToRange.Parent.Name
Exl_WB.Sheets(Rng_Sht_Name).Activate
Exl_WB.Activate
CopyRange.Select
CopyRange.Copy

Count = 0

On Error GoTo ErrorHandler

' << Copying the Named Range as a Pitcure and Pasting default on the Slide >>
CopyRange.CopyPicture xlScreen, xlPicture
New_PowerPoint.Activate

'<< Pasting on the Active Slide >>
PPT_Slide.Select

'<< Pasting with Source Formatting >>
PPT_Slide.Select

PPT_Slide.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

'<< Method-I :Re-size the Picture as it fit to Active Slide >>
With PPT_Slide.Shapes(1)
.Select
.LockAspectRatio = False
.Top = 5
.Width = 710
.Left = 5
.Height = 500
.PictureFormat.TransparentBackground = True
End With

'<< Method-II :Re-size the Picture as it fit to Active Slide >>
NewPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
NewPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 710
NewPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 500
NewPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
NewPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 20

End If

End If

Next Rng

'<<Deleting desired/unwanted Slide >>
Set PPT_Slide = New_PowerPoint.ActivePresentation.Slides(12)
PPT_Slide.Delete

'<<Moving/Changing the Slide Position >>
New_PowerPoint.ActivePresentation.Slides(7).MoveTo ToPos:=23

'<< Saving the Presentation with the Specified Output Name in given Path >>
New_PPT.SaveAs (Save_Path & "\" & OutPut_Name & ".pptx")
New_PPT.Close

Application.Calculation = xlCalculationAutomatic

On Error Resume Next
New_PowerPoint.Quit
Exit Sub

ErrorHandler:
Count = Count + 1

Resume
If Count = 200 Then
Exit Sub
End If

End Sub

Note :
Dear Users , You may not understand this whole Macro , but a few lines in this Macro may useful for your own requirement.

<< Keep Visiting My Blog..Keep Updated..Keep Learning >>

Thanks,
TAMATAM

## Wednesday, 5 November 2014

### How to Insert DEFAULT Constraint Values into a Table in SQL Server

SQL DEFAULT Constraint
The DEFAULT constraint is used to insert a default value into a column.
The default value will be added to all new records, if no other value is specified.

When a Field is declared as DEFAULT , it will take the default value specified , we no need to insert this value in the INSERT INTO statement.So we have to ignore or skip it.This we can do as follows :

My SQL / SQL Server / Oracle / MS Access:

CREATE TABLE Customers
(
C_Id int NOT NULL,
LastName varchar(255) NOT NULL,
FirstName varchar(255),
Gender varchar(50)
)

INSERT Statement for Table with DEFAULT Constraint values
When a Field is declared as DEFAULT , it will take the default value specified , we no need to insert this value in the INSERT INTO statement.So we have to ignore or skip it.This we can do as follows :

INSERT INTO Customers values (123,'Excel','Reddy',DEFAULT,'Male')

Here , In the INSERT INTO statement we passed DEFAULT as a value for the DEFAULT Value City.,so that it will take the Default value specified(Hyderabad) in the Table Creation.

Thanks,
TAMATAM

## Thursday, 30 October 2014

### WorkSheet Event to Zooming in and Out of a Worksheet with Double Click

WorkSheet Event BeforeDoubleClick for Zooming in and Out of a Worksheet with Double Click.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'Check Current Zoom state
'Zoom to 100% if Zoom Level< 100
'Zoom to 150% if Zoom Level= 100

If ActiveWindow.Zoom <> 100 Then
ActiveWindow.Zoom = 100
Else
ActiveWindow.Zoom = 150
End If

End Sub

WorkSheet Evet Image View :

What this Event will do Exactly :

Suppose a sheet has a Zoom Level of 60% as follows:

If you double click on any cell of a Sheet , it will Zooming the Sheet to 100% when Zoom Level is Less or Greater than it.

Again If you double click on any cell of a Sheet , it will Zooming the Sheet to 150% when Zoom Level is at 100%.

Again If you double click on any cell of a Sheet , it will Zooming back the Sheet to 100% as the Zoom Level is at 150% which Greater than 100%.

Thanks
TAMATAM

### Workbook Event BeforeSave Syntax and Example

Workbook Event BeforeSave to Prompts the User for his Response to really Save the Workbook or Not.
The following  example prompts the user for a YES or NO response before saving any workbook.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Alert = MsgBox("Press Yes to Save the Workbook", vbYesNo, "Do You Really Wants to Save ?")
If Alert = vbNo Then Cancel = True

End Sub

BeforeSave Event Image View :

Prompt for the User :
Each time when you press "Ctrl+S" , the Event will occur and Prompt the Msgbox for User Response as below: