Monday, 22 September 2014

How to Hide or Unhide the Specific Sheets with Excel VBA Macro

Excel VBA Macro to Hide or Unhide the Specific Sheets
Let us suppose we have some sheets like...MyReports,My_Links,SLA_Report,Calls_Info in our Workbook.
If you want to Hide or UnHide when Click a Button , you have to assign the Macro to a Button.

Sub Hide_UnHide_TABS()

On Error Resume Next
Application.ScreenUpdating = False

'UnHide if Hideen

    If Sheets("MyReports").Visible = False Or Sheets("My_Links").Visible = False Or _
            Sheets("SLA_Report").Visible = False Or Sheets("Calls_Info").Visible = False Then
            Sheets("MyReports").Visible = True: Sheets("My_Links").Visible = True
            Sheets("SLA_Report").Visible = True: Sheets("Calls_Info").Visible = True
  
 'Hide if  UnHide
    ElseIf Sheets("MyReports").Visible = True Or Sheets("My_Links").Visible = True Or _
            Sheets("SLA_Report").Visible = True Or Sheets("Calls_Info").Visible = True Then
            Sheets(Array("MyReports", "My_Links", "SLA_Report", "Calls_Info")).Select
    ActiveWindow.SelectedSheets.Visible = False
                
    End If

Application.ScreenUpdating = True

End Sub

Thanks,
TAMATAM

Saturday, 20 September 2014

How to Delete Specific or Unwanted Sheets from a Workbook with Excel Macro

Macro To Delete Specific or Unwanted Sheets from a Workbook 
'Suppose in your workbook you have some sheets  as shown below :
"MyReports","My_Links", "Sheet1","SLA_Report","Sheet2", "Calls_Info", "Files_Info", "Sheet3","Control_Panel"

Among these sheets if you want to Keep only "MyReports","My_Links", "SLA_Report", "Calls_Info", "Files_Info", "Control_Panel" Sheets and delete rest all sheets.

To do this task we can use the following Macro with Case Statement.

Public Sub Delte_UnWantedSheets()

    Dim WS_Name As String
    Dim WB_Main As Object
    Dim WS As Worksheet
    
    Set WB_Main = ThisWorkbook

  For Each WS In WB_Main.Sheets
        WS_Name = WS.Name
        
   Select Case WS_Name
        
        Case "MyReports" 
        Case "My_Links"
        Case "SLA_Report"
        Case "Calls_Info"
        Case "Files_Info"
        Case "ControlPanel"
        
   Case Else 'Other than any sheet delete

            Application.DisplayAlerts = False
            WB_Main.Sheets(WS_Name).Delete 
            Application.DisplayAlerts = True

    End Select
        
 Next

 End Sub

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

If you want to Delete the specific sheets from the above example , we can use the following Macro.

Method - II :
 Public Sub Delete_SpecificSheets()

    Dim WS_Name As String
    Dim WB_Main As Object
    Dim WS As Worksheet
    
    Set WB_Main = ThisWorkbook
 For Each WS In WB_Main.Sheets(Array("Sheet1", "Sheet2", "Sheet3"))

    Application.DisplayAlerts = False
            WS.Delete
    Application.DisplayAlerts = True
   
 Next

 End Sub

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

How to Call this Macro in Workbook Event : Workbook_Open()
Be Cautious that the Event will occur on Opening of the Workbook, You may lost your data sheets if wrongly use this event.

Private Sub Workbook_Open()
Call Delte_UnWantedSheets
End Sub





Wednesday, 17 September 2014

How to Sort Pivot Table Row Labels, Column Field Labels and Data Values with Excel VBA Macro

Macro To Sort Pivot Table Row Labels, Column Field Labels and Data Values
Sub Sort_Pivot_Row_Column_Data()
    
Range("G3").Select
    
'To Sort Descending the Column Labels
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Sales_Period").AutoSort _
        xlDescending, "Sales_Period"
        
'To Sort Descending the Row Labels
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Prod_Id").AutoSort _
        xlDescending, "Prod_Id"
        
'To Sort Descending the Data Values based on particular Column Label(3)
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Prod_Id").AutoSort _
        xlDescending, "Sum of Sales", ActiveSheet.PivotTables("PivotTable1"). _
        PivotColumnAxis.PivotLines(3), 1
     
End Sub

Example :
Sample Pivot Data Table



To Sort Descending the Row Labels

    ActiveSheet.PivotTables("PivotTable1").PivotFields("Prod_Id").AutoSort _
        xlDescending, "Prod_Id"

Output :

To Sort Descending the Column Labels

    ActiveSheet.PivotTables("PivotTable1").PivotFields("Sales_Period").AutoSort _
        xlDescending, "Sales_Period"

Output :

To Sort Descending Data Values based on particular Column Label(3) ="Q3-2014"

    ActiveSheet.PivotTables("PivotTable1").PivotFields("Prod_Id").AutoSort _
        xlDescending, "Sum of Sales", ActiveSheet.PivotTables("PivotTable1"). _
        PivotColumnAxis.PivotLines(3), 1

Output :

Thanks,
TAMATAM

Friday, 12 September 2014

How to Lookup or Find Last Matching Value in a List or Group of Values in Excel

Index-Match Function to Lookup or Find  Last Matching Item in a List or Group of Items in Excel.
Suppose we have a as Shown below , Prod_Id,Sales_Region,Sales_Period and Net_Sales.

From the Following data if you want to Find/Lookup the last Matching Product ID for the Period "Q1-2014", we can find using the below  "Index-Mactch-Countif " Combo formula.

=INDEX($A$1:$A$113,MATCH($E$2,$C$1:$C$113,0)+COUNTIF($C$1:$C$113,$E$2)-1)



=INDEX($A$1:$A$113,MATCH($E$2,$C$1:$C$113,0)+COUNTIF($C$1:$C$113,$E$2)-1)

In the above data , the first matching "Prod_Id" for the period "Q1-2014" is "ABC_1234" and the Last Matching value is "GHI_7890".

Note : 
If you want to get the desired last matching value , first you should sort the Lookup value Column.


Please provide your valuable comments or ask the queries that you have , I will be happy to help.

Thanks,
TAMATAM

Thursday, 11 September 2014

How to change Pivot Chart Slicer Filter Item dynamically and and Print the Chart of each Slicer Item on Power Point Slides using Excel Macro

Excel VBA Macro to change Pivot Chart Slicer Filter Item dynamically and and Print the Chart of each Slicer Item on Power Point Slides

Let us Suppose there is Pivot Chart with Slicer in Active Sheet as Shown below :



Now if we want to apply the Filter for each Slicer Item of Sales_Period and Generate the Charts for each Period , which means Chart for Q1-2014,Q2-2014...Q4-2014.

This job we can done using the following Macro.

Sub Create_PPT_Chart_Foreach_SlicerItem()

 Dim New_PowerPoint As Object
 Dim PPT_Present As PowerPoint.Presentation
 Dim ActiveSlide As PowerPoint.Slide
 Dim SL_Item As SlicerItem
 Dim WB As Object

 SavePath = ThisWorkbook.Path
 Present_Name = ThisWorkbook.Name
 Set WB = ActiveWorkbook

 Chart_Name = "Quarterly_Sales" '--This is the Chart Name
 Slicer_Name = "Slicer_Sales_Period1" '--This is the Slicer Name
    
On Error Resume Next
   'Set New_PowerPoint = GetObject(, "PowerPoint.Application")
    Set New_PowerPoint = CreateObject("PowerPoint.Application")
On Error GoTo 0
     
If New_PowerPoint Is Nothing Then
        Set New_PowerPoint = New PowerPoint.Application
End If

If New_PowerPoint.Presentations.Count = 0 Then
    'Set PPT_Present = New_PowerPoint.Presentations.Add
    Set PPT_Present = New_PowerPoint.Presentations.Open("C:\Users\Tamatam\Desktop\Temp\Sales_Deck.pptx")
End If
     
    New_PowerPoint.Visible = True
    

ActiveSheet.ChartObjects(Chart_Name).Activate
    
X = WB.SlicerCaches(Slicer_Name).SlicerItems.Count
WB.SlicerCaches(Slicer_Name).ClearManualFilter

'Loop through Active Chart Slicer Filter Items applying Filter to Generate Chart and Paste into the PowerPoint Slide

For Y = 1 To X
New_PowerPoint.ActivePresentation.Slides.Add New_PowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
Set ActiveSlide = New_PowerPoint.ActivePresentation.Slides(New_PowerPoint.ActivePresentation.
Slides.Count)

'Deleting Title and Body Text boxes from PPT Slide if Not require.
    ActiveSlide.Shapes(1).Delete 'Deleting shape(1)from PPTslide
    ActiveSlide.Shapes(1).Delete 'Deleting shape(2) from PPTslide
    
 Quarter = WB.SlicerCaches(Slicer_Name).SlicerItems(Y).Name

 'Looping through each Slicer Item and Checking condition to Select or Deselect
For Each SL_Item In WB.SlicerCaches(Slicer_Name).SlicerItems

    If SL_Item.Name = Quarter Then
        SL_Item.Selected = True
    Else
        SL_Item.Selected = False
    End If
 Next SL_Item

 ActiveSheet.ChartObjects(Chart_Name).Activate
    ActiveChart.ChartArea.Copy

    ActiveSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

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

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

'Adjusting the positioning of the Chart on Powerpoint Slide
    New_PowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
    New_PowerPoint.ActiveWindow.Selection.ShapeRange.Width = 630
    New_PowerPoint.ActiveWindow.Selection.ShapeRange.Height = 450
    New_PowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
    New_PowerPoint.ActiveWindow.Selection.ShapeRange.Top = 50
    
WB.SlicerCaches(Slicer_Name).ClearManualFilter
Next Y
    
'Saving the Presentation
PPT_Present.SaveAs SavePath & "\" & Present_Name & ".pptx"

PPT_Present.Close
Set PPT_Present = Nothing
Set ActiveSlide = Nothing
'Closing the Powepoint Application Window
New_PowerPoint.Quit
Set New_PowerPoint = Nothing

    
MsgBox "Chart for each Period is Printed on PowerPoint Slides", vbOKOnly, "PPTs Generated Successfully"

End Sub

Thanks,
TAMATAM
         [ BI-Reporting Analyst ]

Wednesday, 10 September 2014

How to Generate PowerPoint Slides for each Chart in Active Sheet with Excel VBA Macro

Excel VBA Macro to Generate PowerPoint Slides for each Chart in Active Sheet
Suppose In a Workbook Sheet if we have some Charts.
Now if you want the Generate the Power Point Slides for each Chart , and we can use the following Macro :
This Macro will generate the Slide for each Chart in Active Sheet and Save the Presentation in active Workbook Path with Workbook Name.
--------------------------------------------------------------------------------------------------------------------------
Sub Create_PPT_Charts_Activesheet()
 Dim New_PowerPoint As Object
 Dim PPT_Present As Powerpoint.Presentation
 Dim ActiveSlide As Powerpoint.Slide
 Dim Cht As Excel.ChartObject
     
 SavePath = ThisWorkbook.Path
 Present_Name = ThisWorkbook.Name
    
On Error Resume Next
   'Set New_PowerPoint = GetObject(, "PowerPoint.Application")
Set New_PowerPoint = CreateObject("PowerPoint.Application")

On Error GoTo 0
     
If New_PowerPoint Is Nothing Then
        Set New_PowerPoint = New Powerpoint.Application
End If

If New_PowerPoint.Presentations.Count = 0 Then
        Set PPT_Present = New_PowerPoint.Presentations.Add
       'Set PPT_Present = New_PowerPoint.Presentations.Open("C:\Users\Tamatam\Downloads\Temp.pptx")
End If
     
New_PowerPoint.Visible = True

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each Cht In ActiveSheet.ChartObjects        
New_PowerPoint.ActivePresentation.Slides.Add New_PowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText

New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
    
Set ActiveSlide = New_PowerPoint.ActivePresentation.Slides(New_PowerPoint.ActivePresentation.Slides.Count)

'Deleting Title and Body Text boxes from PPT Slide if Not require.
 ActiveSlide.Shapes(1).Delete 'Deleting shape(1)from PPTslide
 ActiveSlide.Shapes(1).Delete 'Deleting shape(2) from PPTslide
        
'Copy the chart and paste it into the PowerPoint as a Picture
 Cht.Select
 ActiveChart.ChartArea.Copy
 ActiveSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

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

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

'Adjusting the positioning of the Chart on Powerpoint Slide
New_PowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Width = 620
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Height = 400
    
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Left = 55
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Top = 65
Next Cht

PPT_Present.SaveAs SavePath & "\" & Present_Name & ".pptx"

PPT_Present.Close
Set PPT_Present = Nothing
Set ActiveSlide = Nothing
'Closing the Powepoint Application Window
New_PowerPoint.Quit
Set New_PowerPoint = Nothing
    
MsgBox " Each Chart from Active is Printed on PowerPoint Slides", vbOKOnly, "PPTs Generated Successfully"
End Sub

Thanks,
TAMATAM
      [ BI-Reporting Analyst ]

How to Generate Power Point Presentation Slides for each Chart in Active Sheet with Excel VBA Macro

Excel VBA Macro to Generate Power Point Presentation Slides for each Chart in Active Sheet.
Suppose In a Workbook Sheet if we have some charts with Titles and Notes.
Now if you want the Generate the Power Point Slides for each Chart with Titles and Notes , and we can use the following Macro :

This Macro will generate the Slide for each Chart in Active Sheet and Save the Presentation in active Workbook Path with Workbook Name.

-----------------------------------------------------------------------------------------------------------------------
Sub Create_PPT_Charts_with_Titles_Comments_Activesheet()

 Dim New_PowerPoint As Object
 Dim PPT_Present As Powerpoint.Presentation
 Dim ActiveSlide As Powerpoint.Slide
 Dim Cht As Excel.ChartObject
     
 SavePath = ThisWorkbook.Path
 Present_Name = ThisWorkbook.Name
    
On Error Resume Next
   'Set New_PowerPoint = GetObject(, "PowerPoint.Application")
    Set New_PowerPoint = CreateObject("PowerPoint.Application")
On Error GoTo 0
     
If New_PowerPoint Is Nothing Then
        Set New_PowerPoint = New Powerpoint.Application
End If

If New_PowerPoint.Presentations.Count = 0 Then
        Set PPT_Present = New_PowerPoint.Presentations.Add
       'Set PPT_Present =      New_PowerPoint.Presentations.Open("C:\Users\Tamatam\Downloads\Temp.pptx")
End If
     
    New_PowerPoint.Visible = True
    
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each Cht In ActiveSheet.ChartObjects
        
New_PowerPoint.ActivePresentation.Slides.Add       New_PowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
Set ActiveSlide = New_PowerPoint.ActivePresentation.Slides(New_PowerPoint.ActivePresentation.Slides.Count)

'Set the Title of the slide the same as the Title of the Chart
ActiveSlide.Shapes(1).TextFrame.TextRange.Text = Cht.Chart.ChartTitle.Text
   'ActiveSlide.Shapes(1).TextFrame.TextRange.Font.Size = 30
   
'Add the Comments in the Text box of the slide based on the Region Chart
ActiveSlide.Shapes(2).Width = 180
ActiveSlide.Shapes(2).Left = 490
    
'If the Chart is the "US" Chart, then enter the appropriate Notes
If InStr(ActiveSlide.Shapes(1).TextFrame.TextRange.Text, "US") Then
        ActiveSlide.Shapes(2).TextFrame.TextRange.Text = Range("J7").Value & vbNewLine
        ActiveSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)
        ActiveSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J9").Value & vbNewLine)
        ActiveSlide.Shapes(2).TextFrame.TextRange.Font.Size = 18
'Else if the Chart is the "UK" Chart, then enter the appropriate Notes
ElseIf InStr(ActiveSlide.Shapes(1).TextFrame.TextRange.Text, "UK") Then
        ActiveSlide.Shapes(2).TextFrame.TextRange.Text = Range("J27").Value & vbNewLine
        ActiveSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)
        ActiveSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)
        ActiveSlide.Shapes(2).TextFrame.TextRange.Font.Size = 18
End If
    
'Deleting Title and Body Text boxes from PPT Slide if Not require.
   'ActiveSlide.Shapes(1).Delete 'Deleting shape(1)from PPTslide
   'ActiveSlide.Shapes(1).Delete 'Deleting shape(2) from PPTslide
        
'Copy the chart and paste it into the PowerPoint as a Picture on Slide
    Cht.Select
    ActiveChart.ChartArea.Copy
    ActiveSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
    
'<< Pasting with Source Formatting >>
             PPT_Slide.Select

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

'Adjusting the positioning of the Chart on Powerpoint Slide
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.Width = 455
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.Height = 360
    
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.Left = 35
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
    
Next Cht

'Saving the Presentation
PPT_Present.SaveAs SavePath & "\" & Present_Name & ".pptx"

PPT_Present.Close
Set PPT_Present = Nothing
Set ActiveSlide = Nothing
'Closing the Powepoint Application Window
New_PowerPoint.Quit
Set New_PowerPoint = Nothing

    
MsgBox " Each Chart from Active is Printed on PowerPoint Slides", vbOKOnly, "PPTs Generated Successfully"

End Sub

Thanks,

TAMATAM





Monday, 8 September 2014

How to Delete all Records from a MS Access Table with Excel VBA Macro

Excel Macro to Delete all Records from a MS Access Table

Sub Delete_All_Records_Table()
Dim Str_MyPath As String, Str_DBName As String, Str_DB As String, Str_SQL As String
Dim ADO_RecSet As New ADODB.Recordset
Dim Conn_DB As New ADODB.Connection
Dim Str_SQL 
Dim DB_Table

Str_DBName = "Test_DB.accdb"
Str_MyPath = "C:\Users\Tamatam\Desktop\Temp"
Str_DB = Str_MyPath & "\" & Str_DBName

Conn_DB.Open ConnectionString:="Provider = Microsoft.ACE.OLEDB.12.0; data source=" & Str_DB
Set ADO_RecSet = New ADODB.Recordset
DB_Table = "MyTable"

Str_SQL = "Delete*from MyTable"  'Here you can Pass any SQL Query to Perform

ADO_RecSet.Open Source:=Str_SQL, ActiveConnection:=Conn_DB, CursorType:=adOpenDynamic, LockType:=adLockOptimistic

Conn_DB.Close
Set ADO_RecSet = Nothing
Set Conn_DB = Nothing
MsgBox "All Records from Table has been Deleted SuccessFully", vbOKOnly, "Job Done"

End Sub

Thanks,
TAMATAM

Friday, 5 September 2014

How to Set the Pivot Table Grand Totals on for Rows and Columns in Excel

Excel VBA Macro to Set the Pivot Table Grand Totals on Rows and Columns
Sub PVT_GrandTotals_OnRows_Columns ()
Dim Pivot_Name as String
'Select any in Cell the Pivot Table Area
ActiveSheet.Range("I4").Select 
'Storing Pivot Table Name in a Variable
Pivot_Name = Selection.PivotTable.Name

    With ActiveSheet.PivotTables(Pivot_Name)
        .ColumnGrand = True
        .RowGrand = True
    End With

End Sub

Eg :
Pivot Table without Grand Totals :

Pivot Table with Grand Totals on Rows and Columns:

Manually we can Set the Pivot Table Grand Totals on Rows and Columns by selecting "PivotTable Tools>Design>Grand Totals>On for Rows and Columns" as shown below.



By doing this we will get "Grand Total" for Columns at Last Row and for Rows at Last Column of the Pivot Table.

Thanks,
TAMATAM






Thursday, 4 September 2014

Excel VBA Macro to Import or Copy All Data with SQL Query from from Specific Fields of a MS Access Table into Excel Sheet

Excel VBA Macro to Import or Copy All Data with SQL Query from  from Specific Fields of a MS Access Table into Excel Sheet
Sub Import_SpecificData_From_Access_Table_Fields_To_Excel()
Dim Str_MyPath As String, Str_DBName As String, Str_DB As String, Str_SQL As String
Dim K As Long, N As Long, Fields_Count As Long
Dim Rng As Range

Dim ADO_RecSet As New ADODB.Recordset
Dim Conn_DB As New ADODB.Connection

Str_DBName = "Sales_DB.accdb"
Str_MyPath = "C:\Users\Tamatam\Desktop\Temp"
Str_DB = Str_MyPath & "\" & Str_DBName

'Connect to a data source:
'For Pre - MS Access 2007, .mdb files (viz. MS Access 97 up to MS Access 2003), use the Jet provider:"Microsoft.Jet.OLEDB.4.0".
'For Access 2007 (.accdb database) use the ACE Provider: "Microsoft.ACE.OLEDB.12.0".
'The ACE Provider can be used for both the Access .mdb & .accdb files.

Conn_DB.Open ConnectionString:="Provider = Microsoft.ACE.OLEDB.12.0; data source=" & Str_DB

Dim WS As Worksheet
Set WS = ActiveWorkbook.ActiveSheet

Set ADO_RecSet = New ADODB.Recordset
DB_Table = "Products"

'COPY All RECORDS FROM Selected FIELDS USING CopyFromRecordset:
'Open Recordset/Table:

Str_SQL= "SELECT Product_ID, Prod_Name,Product_Group,Sales_Date FROM Products WHERE Product_Group='Bikes'"


ADO_RecSet.Open Source:=Str_SQL, ActiveConnection:=Conn_DB, CursorType:=adOpenDynamic, LockType:=adLockOptimistic

Set Rng = WS.Range("A1")
Fields_Count = ADO_RecSet.Fields.Count

'Copy Column Names of Table into First Row of the Worksheet:
For K = 0 To Fields_Count - 1
Rng.Offset(0, K).Value = ADO_RecSet.Fields(K).Name
Next K

'Copy All Records values to the Worksheet starting from Second Row :
Rng.Offset(1, 0).CopyFromRecordset ADO_RecSet

'To Copy only 8 Rows and 4 Columns of the Recordset to Excel Worksheet:
'Rng.Offset(1, 0).CopyFromRecordset Data:=ADO_RecSet, MaxRoWS:=8, MaxColumns:=4

'Select a Column Range:
Range(WS.Columns(1), WS.Columns(Fields_Count)).AutoFit
ADO_RecSet.Close

'Close the objectsConn_DB.Close

'Destroy the Variables
Set ADO_RecSet = Nothing
Set Conn_DB = Nothing

MsgBox "Table has been Copied SuccessFully", vbOKOnly, "Job Done"
End Sub

How to Import or Copy All Data from a MS Access Database Table in to Excel Sheet

Excel VBA Macro to Import or Copy All Data from a MS Access Database Table into Excel Sheet
Sub Import_AllData_From_AccDB_Table_To_Excel()
'Using ADO to Import data from an Access Database Table to an Excel worksheet (your host application).

'To use ADO in your VBA project, you must add a reference to the ADO Object Library in Excel(your host application) by clicking Tools-References in VBE,and then choose an appropriate version of Microsoft ActiveX Data Objects x.x Library from the list.

Dim Str_MyPath As String, Str_DBName As String, Str_DB As String, Str_SQL As String
Dim K As Long, N As Long, Fields_Count As Long
Dim Rng As Range

Dim ADO_RecSet As New ADODB.Recordset
Dim Conn_DB As New ADODB.Connection

Str_DBName = "Sales_DB.accdb"
Str_MyPath = "C:\Users\Tamatam\Desktop\Temp"
Str_DB = Str_MyPath & "\" & Str_DBName

'Connect to a data source:
'For Pre - MS Access 2007, .mdb files (viz. MS Access 97 up to MS Access 2003), use the Jet provider:"Microsoft.Jet.OLEDB.4.0".
'For Access 2007 (.accdb database) use the ACE Provider: "Microsoft.ACE.OLEDB.12.0".
'The ACE Provider can be used for both the Access .mdb & .accdb files.

Conn_DB.Open ConnectionString:="Provider = Microsoft.ACE.OLEDB.12.0; data source=" & Str_DB

Dim WS As Worksheet
Set WS = ActiveWorkbook.ActiveSheet

Set ADO_RecSet = New ADODB.Recordset
DB_Table = "Products"

'COPY RECORDS FROM ALL FIELDS USING CopyFromRecordset:
'Open Recordset/Table:

ADO_RecSet.Open Source:=DB_Table, ActiveConnection:=Conn_DB, CursorType:=adOpenStatic, LockType:=adLockOptimistic

Set Rng = WS.Range("A1")
Fields_Count = ADO_RecSet.Fields.Count

'Copy Column Names of Table into First Row of the Worksheet:
For K = 0 To Fields_Count - 1
Rng.Offset(0, K).Value = ADO_RecSet.Fields(K).Name
Next K

'Copy All Records values to the Worksheet starting from Second Row :
Rng.Offset(1, 0).CopyFromRecordset ADO_RecSet

'To Copy only 8 Rows and 4 Columns of the Recordset to Excel Worksheet:
'Rng.Offset(1, 0).CopyFromRecordset Data:=ADO_RecSet, MaxRoWS:=8, MaxColumns:=4

'Select a Column Range:
Range(WS.Columns(1), WS.Columns(Fields_Count)).AutoFit
ADO_RecSet.Close

'Close the objects
Conn_DB.Close

'Destroy the Variables
Set ADO_RecSet = Nothing
Set Conn_DB = Nothing
MsgBox "Table has been Copied SuccessFully", vbOKOnly, "Job Done"

End Sub

How to Select only Non Blank Cells and Enter Same Value in Excel Data

Ctrl+Enter to Fill Same Data in all the Selected Cells
Suppose if we have a Data as below where we have some blank cells in which we want enter the same value.It can be done as follows 

Step 1:
First select the whole Data.



Step 2:
Next  We have to select only the Blank cells in which we want enter the same value.
All the Blank cells can be select by Ctrl+G > Special > Blank cells as follows 

Press Ctrl+G or F5, It will open Go To dialogue box.

Now select "Special" then it will open the Go To Special dialogue box as below


Step 3:
Now select the option "Blanks" and say OK then it will select only the Blank cells in the Data highlighted in blue as below


Now enter the desired value and press "Ctrl+Enter" then same value will fill in all the blank cells as below.




Thanks,
TAMATAM

Wednesday, 3 September 2014

How to Delete a Specific File from a Folder using Excel VBA Macro

Excel VBA Macro to Delete a Specific File from a Folder
Sub Delete_File()
Dim FSO as Object
Dim sFile As String

'Source File Location
sFile = "C:\Users\Tamatam\Desktop\Temp\Test.jpg" 'You can change this Loaction

'Set Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'Check File Exists or Not
If FSO.FileExists(sFile) Then

'If file exists, It will delete the file from source location
FSO.DeleteFile sFile, True
MsgBox "Deleted The File Successfully", vbInformation, "Done!"
Else

'If file does not exists, It will display following message
MsgBox "Specified File Not Found", vbInformation, "Not Found!"
End If
End Sub

Thanks,
TAMATAM

Tuesday, 2 September 2014

How to Send Active Sheet as a PDF Attachment Via Through Outlook Email

Excel VBA Macro to Send Active Sheet as a PDF Attachment Via Through Outlook Email
The following Macro will send the Active Sheet as a Attachment through Outlook in PDF Format.
Sub Email_ActiveSheet_As_PDF()    
'Do not forget to change the Email ID before running this code.
    Dim OutlookApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileFullPath As String
       
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
' Temporary file path where pdf file will be saved before sending it in email by attaching it.    
    TempFilePath = ActiveWorkbook.Path & "\"
    
' Now append a date and time stamp in your pdf file name. 
' Naming convention can be changed based on your requirement.    
TempFileName = ActiveSheet.Name & "_" & Format(Now, "dd-mmm-yyyy") & ".pdf"
    
' Complete path of the file where it is saved.    
FileFullPath = TempFilePath & TempFileName
      
' Now Export the Activesshet as PDF with the given File Name and path.
    
    On Error GoTo ErrMsg:
    With ActiveSheet
        .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    End With
    
' Now open a new mail.
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set NewMail = OutlookApp.CreateItem(0)
    
    On Error Resume Next
    With NewMail
        .To = "your_email@domain.com"
        .CC = ""
        .BCC = ""
        .Subject = "Type your Subject here"
        .Body = "Type your Message body here"
        .Attachments.Add FileFullPath '--- Full path of the pdf where it is saved.
        .Send   '--Or use .Display to show you the email before sending it.
    End With
    
    On Error GoTo ErrMsg:
    
' Since mail has been sent with the attachment.
' Now delete the pdf file from the temp folder.
    
    Kill FileFullPath
    
' Set nothing to the objects created.
    Set NewMail = Nothing
    Set OutlookApp = Nothing
    
' Now set the application properties back to true.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    MsgBox "Email has been Sent Successfully", vbOKOnly, "Job Done"
    Exit Sub

ErrMsg:
        MsgBox err.Description
End Sub

Thanks,
TAMATAM
        [ BI-Developer ]


Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts