Tuesday, 25 November 2014

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

Excel VBA Macro to Create Index with Table of Contents in a Report
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>.
Sub Add_My_Index()
    Dim K As Long
    On Error Resume Next
    Application.DisplayAlerts = False

'Deleting an old Index if it already exist with the Name<MY_INDEX>
    ThisWorkbook.Sheets("MY_INDEX").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
'Adding an Index tab in ThisWorkbook with the Name<MY_INDEX>
    ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Worksheets(1)
    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
        .TintAndShade = 0.349986266670736
        .PatternTintAndShade = 0
    End With

    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With

    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 14
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .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
    ActiveSheet.Hyperlinks.Add _
    Anchor:=ActiveSheet.Cells(K, 1), Address:="", _
    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
   ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 1.5, 2.25, 85.5,25.5).Select
   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.TintAndShade = 0
        .Fill.ForeColor.Brightness = 0
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 11
        .Name = "+mn-lt"
   End With
'Adding the Hyperlink to Shape targeting to INDEX Tab
    ActiveSheet.Shapes.Range(Array(Z)).Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:="", _
    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:
ActiveWorkbook.SaveAs "C:\Users\YourUserName\Desktop\YourFileName", Fileformat:=52 

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.

Please edit this Macro before using as per your Requirement.
----------------------------------------------------------------------------------------------------------------
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
            New_PowerPoint.DisplayAlerts = False
        Else
            New_PowerPoint.Quit
            Set New_PowerPoint = New PowerPoint.Application
            New_PowerPoint.Visible = msoCTrue
            New_PowerPoint.DisplayAlerts = False
           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
             PPT_Slide.Shapes.PasteSpecial(ppPasteDefault,Link:=RangeLink).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.DisplayAlerts = True
        Application.Calculation = xlCalculationAutomatic

    On Error Resume Next
    New_PowerPoint.Quit
        Exit Sub

ErrorHandler:
        Count = Count + 1
    
    Resume
    If Count = 200 Then
MsgBox "Error: Cannot copy the Range from Excel, Please contact Tech Team on this Issue"
        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 >>
<< Please leave your comments on each visit >>

Thanks,
TAMATAM

Wednesday, 5 November 2014

How to INSERT INTO Table with DEFAULT Constraint Values

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),
Address varchar(255),
City varchar(255) DEFAULT 'Hyderabad'
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

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts