How to change the Source of Pivot Table using VBA

How to configure Pivot Table source data externally through VBA

A Pivot Table is linked to a particular source data. If for some reasons, you need that to be configured by users the following code will give some hint:

Sub Change_Pivot_TableDataSource()

Dim oPT As PivotTable

Dim oPC As PivotCache

Dim ORange As Range

Set oPT = ActiveSheet.PivotTables(1)

Set oPC = oPT.PivotCache

Set ORange = Application.InputBox(Prompt:="Select the New DataRange", Type:=8)

oPC.SourceData = "Sheet1!" & Application.ConvertFormula(ORange.Address, xlA1, xlR1C1)

oPT.RefreshTable

If Not oPT Is Nothing Then Set oPT = Nothing

If Not oPC Is Nothing Then Set oPC = Nothing

End Sub

The code gets the new data range through Input Box and modifies the SourceData of the Pivot Table. Change the Sheet name accordingly before you use the code.

How to Check the Source Type of Pivot Table using VBA

Excel VBA Check Pivot Source

The following snippet could help in getting the source type of the Pivot Table

Sub CheckSourceConnection()

Dim pvtCache As PivotCache

Set pvtCache = Application.ActiveWorkbook.PivotCaches.Item(1)

On Error GoTo No_Connection

If pvtCache.SourceType = xlDatabase Then

MsgBox "The data source connection is: " & _

pvtCache.SourceData, vbInformation, "Pivot Table Source"

ElseIf pvtCache.SourceType = xlExternal Then

MsgBox "The data source connection is: " & _

pvtCache.SourceDataFile, vbInformation, "Pivot Table Source"

End If

Exit Sub

No_Connection:

MsgBox "Pivot Table source cannot be determined.", vbInformation, "Pivot Table Source"

End Sub

How to Add Popup Menu Item in Excel/Word using VBA

Create Popup Menu (Right Click menu) using VBA

Here is a simple snippet that will add a menu item to the popup menu and assign a macro to it

Public Const APP_SHORTNAME = "VBADUD_POPUP"

Sub Add_To_Popup_Menu()

Dim ctlNewMenu As CommandBarControl

Dim ctlNewGroup As CommandBarControl

Dim ctlNewItem As CommandBarControl

On Error GoTo Err_Trap

On Error Resume Next

Application.CommandBars("Cell").Controls(APP_SHORTNAME).Delete

On Error GoTo 0

Set ctlNewMenu = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup)

ctlNewMenu.Caption = APP_SHORTNAME

'--- Button - Load Raw Data ------------

Set ctlNewItem = ctlNewMenu.Controls.Add(Type:=msoControlButton)

ctlNewItem.Caption = "Process Data"

ctlNewItem.OnAction = "ProcessData"

Err_Trap:

If Err <> 0 Then

Err.Clear

Resume Next

End If

End Sub

The above will create a new Group and add the “Process Data” control to it.

How to Create PDF from Word Document using VBA

Convert Word to PDF using VBA

Word 2007 has a new method - Document.ExportAsFixedFormat, which saves the document as PDF or XPS format

The following code will save the current document as PDF in the same path

Sub Convert_2_PDF()

ActiveDocument.ExportAsFixedFormat OutputFileName:= _

ActiveDocument.Path & "\" & ActiveDocument.Name & ".pdf", ExportFormat:= _

wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _

wdExportOptimizeForPrint, Range:=wdExportAllDocument, _

Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _

CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _

BitmapMissingFonts:=True, UseISO19005_1:=False

End Sub

Welcome Office 2010

At last the Office 2010 is out - here is what Microsoft has to say about its new baby:


"Microsoft® Office 2010 gives you rich and powerful new ways to deliver your best work - whether you’re at work, home, or school - on a computer, Web browser, or Smartphone. Grab your audience’s attention and inspire them with your ideas using enhanced tools, customizable templates, and photo editing capabilities. Work with multiple people from different locations at the exact same time using new co-authoring capabilities. By offering more ways to access your files from virtually anywhere, Office 2010 puts you in control. "

For more info -->
http://www.microsoft.com/office/2010/

Feel free to post your views on Office 2010

Office 2010 Downloads are available on request (https://microsoft.crgevents.com/Office2010TheMovie/Content/Default.aspx?p=Home&)

VBA Additional Contols not enabled in Tools menu

Probably a silly one, but it took some good time of one of my student. So if the 'Additional Controls' in Excel VBA/Word VBA window is not enabled

Enable the Toolbox --> View -->Toolbox and it becomes enabled

How to Create New Menu using Excel VBA

How to automatically add menu to Excel using VBa

Here is a code to add a new menu and a button whenever a sheet is opened.

Option Explicit
Private Const APPNAME As String = "Sample Menu"
Private Sub Workbook_Open()


Dim ctlNewMenu As CommandBarControl
Dim ctlNewGroup As CommandBarControl
Dim ctlNewItem As CommandBarControl
Dim vID
On Error GoTo Err_DUD

On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls(APPNAME).Delete
On Error GoTo 0
Set ctlNewMenu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
ctlNewMenu.Caption = APPNAME
'--- Add Control Buttons ---------------
Set ctlNewItem = ctlNewMenu.Controls.Add(Type:=msoControlButton)
ctlNewItem.Caption = "Sample Button"
ctlNewItem.OnAction = "SayHello"
ctlNewItem.TooltipText = "Sample Button by VBADUD"
Err_DUD:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub

How to have userform on when working with Word / Excel

How to use Excel and Word Application when userform is displayed


Many times you need to show the userform and work with the application (Excel / Word etc). By default you cannot switch to the spreadsheet or document if the userform is shown.
























Setting the form's ShowModal property to false enables user to use the Application when the userform is displayed

How to Reply to Mail using Outlook VBA

Copy formatted word document to Outlook mail using VBA


Here is a simple snippet that replies to the mail using VBA. The contents of the document has earlier been saved as HTML and the HTML is copied to the mail Item

Public Sub ReplyWithHTML()
Dim oMail As Outlook.MailItem
Dim oFSO
Dim oFS
If Application.ActiveExplorer.Selection.Count Then
If TypeOf Application.ActiveExplorer.Selection(1) Is Outlook.MailItem Then
Set oMail = Application.ActiveExplorer.Selection(1).Reply

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set oFS = oFSO.OpenTextFile("C:\ForBlogger\formedSample.html")

stext = oFS.readall
oMail.BodyFormat = olFormatHTML
oMail.HTMLBody = stext & vbCr & oMail.HTMLBody
oMail.Display
End If
End If
End Sub

Save Powerpoint Slides as Images using VBA

VBA Code to Convert Ppwerpoint Slide to Image (JPEG)

Here is a simple code that will Export all slides in a powerpoint presentation to Jpeg files

Sub Save_PowerPoint_Slide_as_Images()

Dim sImagePath As String
Dim sImageName As String
Dim oSlide As Slide '* Slide Object
Dim lScaleWidth As Long '* Scale Width
Dim lScaleHeight As Long '* Scale Height
On Error GoTo Err_ImageSave

sImagePath = "C:\ForBlogger\"
For Each oSlide In ActivePresentation.Slides
sImageName = oSlide.Name & ".jpg"
oSlide.Export sImagePath & sImageName, "JPG"
Next oSlide

Err_ImageSave:
If Err <> 0 Then
MsgBox Err.Description
End If
End Sub

Disable Close button using Excel VBA

How to disable close button using VBA

If you want to prevent the user to close the Application, you block the menu items, keypress etc. This snippet will help you in disabling the close button of the application.


Sub DisableExcelMenu()
' Remove Exel Menu Items
Dim hMenu As Long

hMenu = GetSystemMenu(Application.hwnd, 0)
Call DeleteMenu(hMenu, SC_CLOSE, MF_BYCOMMAND)
End Sub

The snippet uses WinAPI functions. Include the following functions to your module:



Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Public Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long


Declare Function EnableMenuItem Lib "user32" ( _
ByVal hMenu As Long, _
ByVal uIDEnableItem As Long, _
ByVal uEnable As Long) As Long
'Used to find the Outlook icon in the system tray. If present then Outlook is running
Private Declare Function FindWindow _
Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Public Const MF_BYCOMMAND = &H0&
Public Const MF_BYPOSITION = &H400&
Public Const SC_ARRANGE = &HF110
Public Const SC_CLOSE = &HF060
Public Const SC_HOTKEY = &HF150
Public Const SC_HSCROLL = &HF080
Public Const SC_KEYMENU = &HF100
Public Const SC_MAXIMIZE = &HF030
Public Const SC_MINIMIZE = &HF020
Public Const SC_MOVE = &HF010
Public Const SC_NEXTWINDOW = &HF040
Public Const SC_PREVWINDOW = &HF050
Public Const SC_RESTORE = &HF120
Public Const SC_SIZE = &HF000
Public Const SC_VSCROLL = &HF070
Public Const SC_TASKLIST = &HF130
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOP = 0
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const GWL_STYLE = (-16)


To enable the close button use

Dim hMenu As Long

hMenu = GetSystemMenu(Application.hwnd, 0)
Call EnableMenuItem(hMenu, SC_CLOSE, MF_BYCOMMAND)


Disabled Close Button Excel

Kill Residual Excel Process using VBA

Here is a simple VBA code to "Kill" the Excel process using VBA


Sub Kill_Excel()

Dim sKillExcel As String

sKillExcel = "TASKKILL /F /IM Excel.exe"
Shell sKillExcel, vbHide

End Sub

How to Kill the Word Process using VBA

Developers who are working on Word VBA would have experienced the Word Crash problem more often.

Here is a crude way to kill the Word process.
Sub Kill_Word()

Dim sKillWord As String

sKillWord = "TASKKILL /F /IM Winword.exe"

Shell sKillWord, vbHide

End Sub


Process Window

Use this option if you are sure that the process is unused one

Reset Auto Filter and unhide Rows and Columns using Excel VBA

Autofilters and hidden cells are a nemesis when you perform some operations. The following simple macro will unhide all rows/columns and turn-off the autofilter

Sub RemoveFiltersAndHiddenRows()

Dim oWS As Worksheet

For Each oWS In ActiveWorkbook.Sheets

oWS.AutoFilterMode = False
oWS.UsedRange.Rows.Hidden = False
oWS.UsedRange.Columns.Hidden = False Next

End Sub

How to Save a Chart as Image using Excel VBA

Here is the way to save the active chart in Excel 2007 to a JPG file. It is better to size the chart appropriately before exporting it as an image.

Sub Save_ChartAsImage()

Dim oCht As Chart

Set oCht = ActiveChart

On erRROR GoTo Err_Chart

oCht.Export Filename:="C:\PopularICON.jpg", Filtername:="JPG"

Err_Chart:

If Err <> 0 Then

Debug.Print Err.Description

Err.Clear

End If

End Sub

The code uses Export method to save the chart in graphics format

How to Install Analysis ToolPak in Excel 2007

How to Install Analysis ToolPak in Excel 2007

1. Click the Microsoft Office Button , click Excel Options, and then click the Add-ins category.

In the Manage list, select Excel Add-ins, and then click Go.

In the Add-ins available list, select the Analysis ToolPak box, and then click OK.

If necessary, follow the instructions in the Setup program.

The analysis pack will be loaded and displayed on the menu

How to Connect SQL Express 2005 from VBA

Excel VBA retrieve data from SQL Server 2005


Here is a way to connect to SQL Express 2005 from Excel VBA

Sub Connect2SQLXpress()

Dim oCon As ADODB.Connection

Dim oRS As ADODB.Recordset

Set oCon = New ADODB.Connection

oCon.ConnectionString = "Driver={SQL Native Client};Server=.\SQLEXPRESS;Database=DB1; Trusted_Connection=yes;"

oCon.Open

Set oRS = New ADODB.Recordset

oRS.ActiveConnection = oCon

oRS.Source = "Select * From Table1"

oRS.Open

Range("A1").CopyFromRecordset oRS

oRS.Close

oCon.Close

If Not oRS Is Nothing Then Set oRS = Nothing

If Not oCon Is Nothing Then Set oCon = Nothing

End Sub

The code uses ActiveX Data Objects (ADO). You need to add a reference to it as shown below

How to update an Access Table using VBA

How to update an Access Table using ADO

The following code snippet would be helpful to update an Access 2007 database table using VBA. The code uses ADO and requires a reference to ActiveX Data Objects Library

The sample uses a simple table which contains a name and a location field.

The code uses the SQL update query to update the database. The query is executed by the ADO’s command execute method

Sub Simple_SQL_Update_Data()

Dim Cn As ADODB.Connection '* Connection String

Dim oCm As ADODB.Command '* Command Object

Dim sName As String

Dim sLocation As String

Dim iRecAffected As Integer

On Error GoTo ADO_ERROR

Set Cn = New ADODB.Connection

Cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\comp\Documents\SampleDB.accdb;Persist Security Info=False"

Cn.ConnectionTimeout = 40

Cn.Open

sName = "Krishna Vepakomma"

sLocation = "Cincinnati, OH"

Set oCm = New ADODB.Command

oCm.ActiveConnection = Cn

oCm.CommandText = "Update SampleTable Set Location ='" & sLocation & "' where UserName='" & sName & "'"

oCm.Execute iRecAffected

If iRecAffected = 0 Then

MsgBox "No records inserted"

End If

If Cn.State <> adStateClosed Then

Cn.Close

End If

Application.StatusBar = False

If Not oCm Is Nothing Then Set oCm = Nothing

If Not Cn Is Nothing Then Set Cn = Nothing

ADO_ERROR:

If Err <> 0 Then

Debug.Assert Err = 0

MsgBox Err.Description

Err.Clear

Resume Next

End If

End Sub

Table Before Update Command

Table After Update Command

No value given for one or more required parameters. (ADO Error)

There are many reasons for this error:

1. Parameter name not spelt correctly
2. Case is not correct in parameter (firstname instead of FirstName )
3. Passing incorrect type, for example, numeric instead of string - pass the string within quote

How to extract all synonyms of a given word using VBA

The following code snippet gives a hint on how to extract synonym list using Word VBA

Sub Retrieve_Word_Info()

Dim arSynonyms

Dim oSynInfo As SynonymInfo

Dim arSynList

Dim sWord As String

sWord = "call"

Set oSynInfo = Application.SynonymInfo(sWord)

If oSynInfo.Found = True Then

For i1 = 1 To oSynInfo.MeaningCount

arSynList = oSynInfo.SynonymList(i1)

For i2 = 1 To UBound(arSynList)

MsgBox oSynInfo.MeaningList(i1) & " := " & arSynList(i2)

Next

Next i1

End If

End Sub