Invoking Stored Procedure in VBA

I have created a stored procedure sp_displayspl_Members in MSSQL Server.
Code to create Stored procedure:
if exists(select * from sysobjects where name='sp_displayspl_Members')begindrop procedure sp_displayspl_Members;endgocreate procedure sp_displayspl_Members @membertype char(8)as
Select
Through this stored procedure we have selected records where Membertype='Social'

In order to open a stored procedure within ActiveX Data Objects (ADO), you must first open a Connection Object, then a Command Object, fill the Parameters Collection with one parameter in the collection for each parameter in the query, and then use the Command.Execute() method to open the ADO Recordset. VBA Code:


Sub callSP()
Dim con1 As New ADODB.Connection
Dim cmd1 As New ADODB.Command
Dim rs1 As New ADODB.Recordset
Dim reccounter As Long
Dim spcreate, spdrop As String
On Error GoTo Errorhandler
spdrop = "if exists(select * from sysobjects where name='sp_displayspl_Members') drop procedure sp_displayspl_Members"
spcreate = "create procedure sp_displayspl_Members @membertype char(8) as Select * from Member where Membertype=@membertype"
        con1.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Data Source=NEW\SQLEXPRESS;"
        con1.Open
          
        Set rs1 = con1.Execute(spdrop)
        Set rs1 = Nothing
           
         Set rs1 = con1.Execute(spcreate)
        Set rs1 = Nothing
        
       
        cmd1.ActiveConnection = con1
        cmd1.CommandText = "sp_displayspl_Members"
        cmd1.CommandType = adCmdStoredProc
       
        cmd1.Parameters(1).Value = "Social"
       
        
        Set rs1 = cmd1.Execute()
       
        Do While Not rs1.EOF
        reccounter = reccounter + 1
               val1 = rs1(0)
               val2 = rs1(1)
               val3 = rs1(2)
               val4 = rs1(3)
               val5 = rs1(4)
               val6 = rs1(5)
               val7 = rs1(6)
               val8 = rs1(7)
                Cells(reccounter, 1) = val1
                Cells(reccounter, 2) = val2
                Cells(reccounter, 3) = val3
                Cells(reccounter, 4) = val4
                Cells(reccounter, 5) = val5
                Cells(reccounter, 6) = val6
                Cells(reccounter, 7) = val7
                Cells(reccounter, 8) = val8
                rs1.MoveNext
               
        Loop
        If rs1.State <> adStateClosed Then
                rs1.Close
                con1.Close
                Set rs1 = Nothing
                Set con1 = Nothing
         End If
Exit Sub
Errorhandler:
    MsgBox "Error description:" & Err.Description
End Sub * from Member where Membertype=@membertype

VBA Code for Chart Event

This event works for Chartsheet not for embedded chart.
VBA Code is mentioned below(for top 10 billionaire chart)




Dim chrt As Chart
Dim ser As Series
Dim chrtdata, chrtlbl, txtBox As Object, elementId As Long, arg1 As Long, arg2 As Long
Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
On Error Resume Next
Application.ScreenUpdating = False
Set chrt = ActiveChart
Set ser = ActiveChart.SeriesCollection(1)
chrtdata = ser.Values
chrtlbl = ser.XValues
txtBox.Delete
chrt.GetChartElement x, y, elementId, arg1, arg2
    If elementId = xlSeries Then
 
        Set txtBox = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, x - 135, y - 125, 100, 100)
        txtBox.Height = 56
        txtBox.Width = 80
        txtBox.Name = "Hover"
        txtBox.Fill.ForeColor.SchemeColor = 27
        txtBox.Line.DashStyle = msoLineSolid
        txtBox.TextFrame.Characters.Text = "Sales Amount: " & "$" & chrtdata(arg2) & Chr(10) & "Sales Person: " & chrtlbl(arg2)
        txtBox.TextFrame.Characters.Font.Size = 10
        txtBox.TextFrame.Characters.Font.ColorIndex = 1
        txtBox.TextFrame.Characters.Font.Bold = True
        ser.Points(arg2).Interior.ColorIndex = 38
     Else
        ser.Interior.ColorIndex = 18
    End If
End Sub

https://drive.google.com/file/d/0B23eJ2xd9ODyTTBXcjA2TjZmQzg/edit?usp=sharing

Import Excel Worksheet data to SQLServer

We have created a Dummy Database called Member into SQL Server with following paramater:

MemberIf int primary key, Firstname char(20)not null,Lastname char(20) not null,Phone char(20)not null,Handicap Int not null,Joindate Datetime not null,Gende char(1) not null, Membertype char(20) foreign key
Vba Code for Entering data from Excel worksheet:

Sub browseRecord()
Dim selrng, dataval As Range
Dim strsql As String
Dim MemberId, Handicap As Integer
Dim Firsname, Lastname, phone, JoinDate, Gender, MemberType As String
Dim cnn As New ADODB.Connection
On Error GoTo errorhandler
cnn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Data Source=NEW\SQLEXPRESS;"
cnn.Open

On Error Resume Next
Dim rowcount As Variant
Set dataval = Range("A1")
Set selrng = Range("A:A")
rowcount = WorksheetFunction.CountA(selrng)
        For i = 1 To rowcount
                 MemberId = CInt(dataval.Offset(i - 1, 0))
                 Firsname = dataval.Offset(i - 1, 1)
                 Lastname = dataval.Offset(i - 1, 2)
                 phone = dataval.Offset(i - 1, 3)
                 Handicap = CInt(dataval.Offset(i - 1, 4))
                 JoinDate = dataval.Offset(i - 1, 5)
                 Gender = dataval.Offset(i - 1, 6)
                 MemberType = dataval.Offset(i - 1, 7)
                
                 strsql = "Insert  into Member values( " & MemberId & ",' " & Trim(Firsname) & "'," & "'" & Trim(Lastname) & "','" & phone & "'," & Handicap & ",'" & JoinDate & "'," & "'" & Gender & "'," & "'" & Trim(MemberType) & "');"
                 cnn.Execute strsql
                 MsgBox strsql
        Next i
        cnn.Close
        Set cnn = Nothing
        Exit Sub
errorhandler:
        MsgBox "Error" & Err.Description
End Sub

                                 

Turn VBA code into Add-In

Turn Vba Code into excel Add-in
Find specific in all Worksheet

An Excel Add-In is a file (usually with an .xlam, .xla extension) that Excel can load when it starts up. The file contains
code (VBA in the case of an .xla/.Xlam Add-In) that adds additional functionality to Excel, usually in the form of new functions.

You can say it's a modified version of UDF which can be used across all worksheets.

How to crete an Add-In:

1.Open an excel file with normal VBA code which you want to convert an Add-In

2.Open Project properties Under General tab give a new name to the project.Under Protection tab, lock the project with new
  password.

3.In Save as Type drop-down list,select Excel Add-In(*.xlam/*.xla).

4.Click Save

A new Add-In file is created.

Installing Add-In
1. Press Alt TI in already opened excel file
2. Click Browse button and locate the Add-In file just created.
3. After adding new Add-In  in its list,click the check button of respective Add-In; it will be added in Add-In's list.
4. Don't save opened file.
5. Restart Excel

To distribute Add-In you just distribute the (*.Xlam/*.xla) file to respective user.


VBA code for calculating Age:




Function calcAge(dob As Date)
    If dob = 0 Then
        MsgBox "No Birthdate"
    Else
        Select Case Month(Date)
            Case Is < Month(dob)
                clacAge = Year(Date) - Year(dob) - 1
            Case Is = Month(dob)
                If Day(Date) >= Day(dob) Then
                    calcAge = Year(Date) - Year(dob)
                Else
                    calcAge = Year(Date) - Year(dob) - 1
                End If
            Case Is > Month(dob)
                calcAge = Year(Date) - Year(dob)
        End Select
    End If
End Function

Worksheet Change Event

The Change Event is triggered when any cell in a worksheet is changed by the user or by any VBA application. Worksheet change event receives a Range object as its target argument.

VVBA code for validating data entry:

Private Sub Worksheet_Change(ByVal target As Range)
Dim myrng As Range, cell As Range
On Error Resume Next
Set myrng = Range("ValidRange")
   For Each cell In Intersect(myrng, target)
       If cell.Value > 12 Or cell.Value < 1 Then
            MsgBox "Please enter a value between 1 and 12"
            Range(cell.Address).Select
       End If
   Next cell
    Application.EnableEvents = True
End Sub

Create Multiple Worksheet

Following VBA Code is an utility code for creating multiple worksheets  for a month on a daily basis:



Option Explicit

Sub createMultipleWorksheet()
Dim strdate As String
Dim numdays As Long, i As Long

Dim wsbase As Worksheet
On Error GoTo Errorhandler
    Do
        strdate = Application.InputBox("Please enter month and year:mm/yyyy", Title:="Month and year", Default:=Format(Date, "mm/yyyy"), Type:=2)
     
       If IsDate(strdate) Then Exit Do
       If MsgBox("Please enter a valid date such as ""01/2008"" " & vbLf & vbLf & "Shall we try again?", vbYesNo + vbExclamation, "Invalid date") = vbNo Then End
     
    Loop
    numdays = Day(DateSerial(Year(strdate), Month(strdate) + 1, 0))
 
    Set wsbase = Sheets("Sheet1")
    For i = 1 To numdays
        wsbase.Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Name = Format(DateSerial(Year(strdate), Month(strdate), i), "mm.dd.yy")
    Next i
Exit Sub
Errorhandler:
MsgBox "Error" & Err.Description

End Sub