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

Extracting Data from Website to Excel

Sometimes we need to extract some stock price related info from website to Excel worksheet. Here is the VBA Code to extract info from Yahoo Finance:


Sub getInfoOnine()
Dim qt As QueryTable
Set qt = ActiveSheet.QueryTables.Add(Connection:="Url;http://finance.yahoo.com/q?s=infy", Destination:=Range("B2"))
With qt
        .Name = "Getting online data"
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingAll
        .WebTables = "1,2,3"
        .EnableRefresh = True
        .RefreshPeriod = 10
        .Refresh
End With
End Sub

Example Messagebox Function in VBA

It's a sample code for messagebox function in vba for excel spreadsheet

Sub diplaymessageBox()
Dim stranswer As VbMsgBoxResult
stranswer = MsgBox("Would you like to colour the cell?", vbQuestion + vbYesNo, "Select Option")
If stranswer = vbYes Then
        Selection.Interior.ColorIndex = 8
    End If
End Sub

Importing Txt file into Excel

VBA Code for importing a text file into excel spredaheet

Sub importFile()

Dim filepathName As String

filepathName = InputBox("Enter complete filepath name:")

    With ActiveSheet.QueryTables.Add(Connection:="text;" & filepathName, Destination:=Range("A1"))
        .Name = "Excel Importing Text File"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = True
        .TextFileColumnDataTypes = Array(1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
   
    End With

End Sub

Automated Search Option for Spreadsheet

Following VBA code is  an extension of existing Find function in  Excel Spreadsheet. Though normal Find

function you have to find desired data in each sheet seperately. Through below mentioned code you can get

the result of searched value across all cells of spreadsheets in an Excel Workbook. Wherever the code will

find the data, it will automatically bold , enlarge that cell and save the worksheet.


Sub searchthroughSheet()
Dim mydata As Variant
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Dim c As range
mydata = InputBox("Enter your value to search:")
On Error Resume Next
For Each ws In wb.Worksheets
With Worksheets(ws.Index).Cells
Sheets(ws.Index).Select
    Set c = .find(mydata, LookIn:=xlValues)
    If Not c Is Nothing Then
            firstaddress = c.Address
            Do
                MsgBox "Match found in" & Worksheets(ws.Index).Name & c.Address
                range(c.Address).Select
                Selection.Font.Bold = True
                Selection.Font.Size = 20
                ActiveWorkbook.Save
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
End With
Next ws
End Sub

Copy Specific Cells in a Worksheet by VBA

'VBA  Code to copy specified cells from all the files in a folder

Option Explicit
Dim objFso As Object, pathname As String, eachfile, objFolder As Object, wb As Workbook
Sub getDatafromAnotherfile()
Set objFso = New Scripting.FileSystemObject
Set wb = ThisWorkbook
pathname = "C:\Users\AJS-Client\Desktop\Check\GMU-Dubai21.12.2013"
Set objFolder = objFso.GetFolder(pathname)
For Each eachfile In objFolder.Files
MsgBox objFso.GetExtensionName(eachfile)
   If objFso.GetExtensionName(eachfile) = "xls" Then
 
        Call Openfile(eachfile)
   End If
 
Next
Set wb = Nothing
End Sub

Public Sub Openfile(eachfile)


Workbooks.Open eachfile

ActiveWorkbook.Sheets(1).Range("A2:C2").Copy wb.Sheets(1).Range("A2")
ActiveWorkbook.Close


End Sub

Dynamic Dashboard Report Without VBA

Dashboard Report(Above)
This is a chart of Pollution Control department that compares the city by month in following categories:

Average Precipitation,Average Temperature,Percent Sunshine,Average Wind Speed. We have used option button,vlook-up and name range generate this dynamic Dashboard 

Get Next Blank Cell in a Spreadsheet

VBA Code for finding next blankcell in a Spreadsheet:





Sub getnextblankcell()
Dim selrange, nextrange, result As Range
Dim dir As String
On Error Resume Next
dir = InputBox("Enter direction:Up/Down/Left/Right")
Set selrange = Application.InputBox("Select Range:", "Choose", Type:=8)
    If dir = "Up" Then
        Set nextrange = selrange.End(xlUp)
        Set result = nextrange.Offset(-1, 0)
        result.Select
    ElseIf dir = "Down" Then
        Set nextrange = selrange.End(xlDown)
        Set result = nextrange.Offset(1, 0)
        result.Select
    ElseIf dir = "Right" Then
        Set nextrange = selrange.End(xlToRight)
        Set result = nextrange.Offset(0, 1)
        result.Select
    ElseIf dir = "Left" Then
        Set nextrange = selrange.End(xlToLeft)
        Set result = nextrange.Offset(0, -1)
        result.Select
        Set result = Nothing
    End If
End Sub

For further resources

Code for Retrieving Data from SQL Server 2005 to Excel Spreadheet

Altough you can retrieve data from SqlServer 2005 to excel spreadsheet under   'Get External Data ' option; sometimes you need to run your own SQL query to pull back required fields from different tables to work with.

Here is  a simple VBA code to run your own SQL query  using SQL  Server 2005's in-bulit driver SQLOLEDB.1


Option Explicit
Sub retrievedata()
Dim con As New ADODB.Connection
Dim rst As New ADODB.Recordset
Application.ScreenUpdating = False
On Error Resume Next
    con.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Data Source=NEW\SQLEXPRESS;"
    con.Open
    rst.ActiveConnection = con
    rst.Source = "Select * from Member where Gender='F' "
    rst.Open
    Range("A2").CopyFromRecordset rst
    rst.Close
    con.Close
    Set rst = Nothing
    Set con = Nothing
    Application.ScreenUpdating = True
End Sub

Creating a complex Pivot Table

There is a budget spreadsheet mentioned below:

VBA code for creating pivot table with variance analysis:

Sub Macro1()

'
' Macro1 Macro
'

'

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        Range("A1").CurrentRegion.Address, Version:=xlPivotTableVersion12).CreatePivotTable _
        TableDestination:="", TableName:="PivotTable1", DefaultVersion:= _
        xlPivotTableVersion12
    ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
    ActiveSheet.Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1")
        .PivotFields("Department").Orientation = xlRowField
        .PivotFields("Division").Orientation = xlPageField
        .PivotFields("Category").Orientation = xlPageField
        .PivotFields("Budget").Orientation = xlDataField
       
        .PivotFields("Actual").Orientation = xlDataField
       
        .PivotFields("Month").Orientation = xlColumnField
        .DataPivotField.Orientation = xlRowField
        .CalculatedFields.Add "Variance", "=Budget-Actual"
        .PivotFields("Variance").Orientation = xlDataField
        .DataBodyRange.NumberFormat = "0,000"
        .TableStyle = TableStyle2
        .DisplayFieldCaptions = False
        .PivotFields("Sum of Budget").Caption = " Budget"
        .PivotFields("Sum of Actual").Caption = " Actual"
        .PivotFields("Sum of Variance").Caption = " Variance"
     End With
   
End Sub

Summation of unique no. in a Spreadsheet range

VBA code for summation of unique no.s in an excel spreadsheet range:


Function uniquesum(Rg As range)
    Dim rng As range
    Dim ccell As New Collection
    Dim var As Variant
    On Error Resume Next
For Each rng In Rg
ccell.add rng.Value, CStr(rng.Value)
Next rng
For Each var In ccell
uniquesum = var + uniquesum
Next var
End Function

Representing Dynamic Chart for Survey Data

Whenever you need to draw dynamic chart in a userform depending on parameters & factors of survey as mentioned above,VBA macro code is mentioned below.You will have to select one parameter at a time mentioned at the left hand side of the chart.The only requirement for this code is to set focus of your cursors on data points on an excel spreadsheet and to load an image control in form

Private Sub UserForm_initialize()
Call showGraph

End Sub


Sub showGraph()
Dim currentrow As Long
Dim currentchart As Chart
Dim pathname As String
Dim chartheader, datasource, chartdatasource As Range
   currentrow = ActiveCell.Row
    On Error GoTo Errorhandler

    If currentrow <= 1 Then
       MsgBox "Move cell pointer to a row that contains data of Row Labels"
    End If
   
    Set chartheader = ActiveSheet.Range("A1:F1")
    Set datasource = ActiveSheet.Range(Cells(currentrow, 1), Cells(currentrow, 6))
   
    Set chartdatasource = Union(chartheader, datasource)
   
    Range(chartdatasource.Address).Select
    ActiveSheet.Shapes.AddChart.Select
   
    ActiveChart.SetSourceData Source:=chartdatasource, PlotBy:=xlRows
    ActiveChart.ChartType = xlColumnClustered

        pathname = ThisWorkbook.Path & "\temp.gif"
        If Not Dir(pathname) = "" Then
               Kill pathname
            End If
    ActiveChart.Export Filename:=pathname, filtername:="gif"
   
   
    pathname = ThisWorkbook.Path & "\temp.gif"
    UserForm1.Image1.Picture = LoadPicture(pathname)
   
        ActiveSheet.ChartObjects.Delete
   
   
    Exit Sub
Errorhandler:
    MsgBox "Error description" & Err.Description
End Sub

Automated Data entry into Spreadsheet through Userform

This is a simple data entry form for a spredsheet wilth two columns Product & Price. VBA Code for dataentry into spredsheet through userform

Private Sub Enter_Click()
Dim nextrow As Long
Sheets("sheet1").Activate
nextrow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
    If txtproduct.Text = "" Then
        MsgBox "Enter a Product name"
       
    End If
    Cells(nextrow, 1) = txtproduct.Text
    If txtprice.Text = "" Then
    MsgBox "Enter a Price"
    End If
    Cells(nextrow, 2) = txtprice.Text
End Sub
This automated concept is useful for dataentry when there are large no. of cloumns in a spreadsheet.

Highlight duplicate records in a Spreadsheet Range

VBA Macro code for highlighting duplicate records in a spreadsheet



Sub showduplicate()
Dim rng As Range
Dim cell As Variant
Set rng = Application.InputBox("Select your Range", "My range", Type:=8)

    For Each cell In rng
        If WorksheetFunction.CountIf(rng, cell.Value) > 1 Then
        cell.Interior.ColorIndex = 16
        End If
    Next cell
End Sub

Example for Worksheetfunction.trend()

You can use TREND for polynomial curve fitting by regressing against the same variable raised to different powers. For example, suppose column A contains y-values and column B contains x-values. You can enter x^2 in column C, x^3 in column D, and so on, and then regress columns B through D against column A.


Simplae VBA test code

Sub test()
Dim knowny, knownx, myval As Variant
Dim newx As Variant
On Error Resume Next
knowny = Array(2, 4, 6, 8, 10)
knownx = Array(1, 2, 3, 4, 5)
newx = Array(8)
myval = Application.WorksheetFunction.Trend(knowny, knownx, newx)
MsgBox myval(1)
End Sub

How to Use R1C1 format

VBA  macro code to calculate average in a spreadsheet :



Sub calcaverage()
Range("D1").Select
ActiveCell.Value = "Average"
ActiveCell.Offset(1, 0).Select
    Do While Not IsEmpty(ActiveCell.Offset(0, -2))
        ActiveCell.FormulaR1C1 = "=Average(RC[-3],RC[-2])"
        ActiveCell.Offset(1, 0).Select
    Loop
End Sub

To Get Values from a Chart using VBA

Macro Code to retrieve source data from chart in a spreadsheet:


Sub getchartValues()
Dim numOfRows As Integer
Dim X As Object
On Error Resume Next
        temp = 2
        numOfRows = UBound(ActiveChart.SeriesCollection(1).XValues)
       
        For Each X In ActiveChart.SeriesCollection
        'Sets the name of each seriescollection
        Sheets("sheet1").Cells(1, temp) = X.Name
       
            With Sheets("Sheet1")
            'Sets all x-axis unit name vertically
                .Range(.Cells(2, 1), .Cells(numOfRows, 1)) = Application.Transpose(ActiveChart.SeriesCollection(1).XValues)
            End With
            With Sheets("Sheet1")
            'sets all x-axis value horizontally
                .Range(.Cells(2, temp), .Cells(numOfRows, temp)) = Application.Transpose(X.Values)
            End With


            temp = temp + 1
        Next X
       
End Sub

Display Chart in User Form via VBA

Whenver you want to display chart in user form; create chart on the basis of collated data    in another spreadsheet.
Use VBA code to display that chart into User form and then hide that  spredsheet.

VBA code for that is as follows:

Option Explicit
Dim chartnum As Integer
Private Sub UserForm_Initialize()
    chartnum = 1
    updatechart
End Sub
Private Sub updatechart()
    Dim CurrentChart As Chart
    Dim Fname As String

   
    Set CurrentChart = Sheets("Charts").ChartObjects(chartnum).Chart
    CurrentChart.Parent.Width = 390
    CurrentChart.Parent.Height = 190
    Fname = ThisWorkbook.Path & "\temp.gif"
    CurrentChart.Export Filename:=Fname, FilterName:="GIF"
    Image1.Picture = LoadPicture(Fname)
End Sub

Sort Worksheet using VBA

When you have more than 10 worksheets in your excel file, it's very urgent to sort these sheets on the basis of their sheet name so that we can find them very easily.

VBA code for that is as follows:


Sub sortSheet()
Dim sheetcount, a, b As Integer
Application.ScreenUpdating = False
sheetcount = Worksheets.Count
If sheetcount = 1 Then Exit Sub
For a = 1 To sheetcount - 1
    For b = a + 1 To sheetcount
    If Worksheets(b).Name < Worksheets(a).Name Then
    Worksheets(b).Move before:=Worksheets(a)
    End If
    Next b
Next a
Application.ScreenUpdating = True
End Sub

Sorting Spreadsheet Data using VBA

Sometimes you need to display top 10 sales performers in your spreadsheet out of  thousand records.
VBA code for this operation is as follows:





Sub topTen()
Dim rng As Range
'Remove any existing Sort
ActiveSheet.Sort.SortFields.Clear
'Remove any existing filter
If ActiveSheet.AutoFilterMode = True Then
ActiveSheet.AutoFilterMode = False
End If
Set rng = Application.InputBox("My Range", "Select Range to Sort", Type:=8)
Range("A1").AutoFilter Field:=4, Criteria1:=10, Operator:=xlTop10Items
Range(rng.Address).Select
'Sorting of entire sheet on the basisof column D1
Selection.Sort key1:=Range("D1"), order1:=xlDescending
End Sub

Finding Square of a Range

Vba code:


Sub chcksquare()
Dim rcount, tempval, tempcount As Integer
Dim rng As Range
Set rng = Application.InputBox("Select Range", "My Range", Type:=8)
rcount = rng.Rows.Count
Do
tempval = ActiveCell.Offset(tempcount, 0)
ActiveCell.Offset(tempcount, 1).Formula = "=" & tempval & "*" & tempval
tempcount = tempcount + 1
Loop Until tempcount = rcount
End Sub

Delete Empty Rows in a Spreadsheet

Automated VBA Macro code for deleteing empty rows in a large Excel Spreadsheet:


Sub deleteemptyRows()
Dim lastrow, r As Long
lastrow = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = lastrow To 1 Step -1
    If Application.WorksheetFunction.CountA(Rows(r)) = 0 Then
    Rows(r).Delete
    End If
Next r
End Sub

Add Comments in a Spreadsheet

If you want to add comments on  specific cells of a Spreadsheet try following VBA code:




Sub commentonThem()
Dim cell As Range
On Error Resume Next
Selection.ClearComments
For Each cell In ActiveSheet.UsedRange
If cell.Formula <> "" Then
    If cell.HasFormula = True Then
        cell.AddComment
        cell.Comment.Visible = False
        cell.Comment.Text Text:=cell.Formula
     End If
End If
Next cell
End Sub

Get data from a closed Worksheet

Using XLM macro you can extract data from a closed Excel worksheet:

Sub getinfofromClosedile()
Dim pathname, filename, wsname As String
filename = "Delhi Store locator.xls"
pathname = "e:\"
wsname = "SalesReport"
For r = 1 To 5
    For c = 1 To 2
        add1 = Cells(r, c).Address
        Cells(r, c) = readclosedFile(pathname, filename, wsname, add1)
    Next c
Next r
End Sub
Private Function readclosedFile(pathname, filename, wsname, cellref)
Dim arg As String
arg = "'" & pathname & "[" & filename & "]" & wsname & "'!" & Range(cellref).Address(, , xlR1C1)
readclosedFile = ExecuteExcel4Macro(arg)
End Function

Add Databar in MS Excel using VBA

In excel you can compare numbers in a column using Databar.Normally you can add Databar through conditional formatting. But you can add databar using VBA Code also. Sample code is as follows:

Sub createdatabar()
Dim mydatabar  As Databar
Dim selrng As Range
Set selrng = Application.InputBox("My Range", "Select Range", Type:=8)
selrng.Select
Set mydatabar = Selection.FormatConditions.AddDatabar

End Sub

Automated Vlookup inVBA

Sometimes we need to use vlookup for more than 1000 rows in a single sheet for discrete columns. Today I'll publish automated vlookup VBA code and it'll take care of all rows even if next row is blank .

Sub autovlookup()
    Dim lookupcell, sheetname, tempcelladdress As String
    Dim cntrow, tempcount As Long
    sheetname = ActiveSheet.Name
    cntrow = Application.WorksheetFunction.CountA(Range("A:A"))
    tempcount = 1
   
   
    On Error Resume Next
    Do
        ActiveCell.Offset(1, 0).Select
        tempcelladdress = Range(ActiveCell.Address).Offset(0, -1).Address
       
   
    If Len(tempcelladdress) = 4 Then
    lookupcell = Mid(tempcelladdress, 2, 1) & Mid(tempcelladdress, 4, 1)
    ElseIf Len(tempcelladdress) = 5 Then
    lookupcell = Mid(tempcelladdress, 2, 1) & Mid(tempcelladdress, 4, 2)
    ElseIf Len(tempcelladdress) = 6 Then
    lookupcell = Mid(tempcelladdress, 2, 1) & Mid(tempcelladdress, 4, 3)
    ElseIf Len(tempcelladdress) = 7 Then
    lookupcell = Mid(tempcelladdress, 2, 1) & Mid(tempcelladdress, 4, 4)
    ElseIf Len(tempcelladdress) = 8 Then
    lookupcell = Mid(tempcelladdress, 2, 1) & Mid(tempcelladdress, 4, 5)
    End If
    If Range(ActiveCell.Address).Offset(0, -1).Value <> "" Then
    tempcount = tempcount + 1
    ActiveCell.Formula = "=vlookup(" & lookupcell & ",'SalesData'!D1:F3457,2,0)"
    End If
   
    Loop Until tempcount = cntrow
End Sub

Remove Special Character in VBA

Some times in excel we face a problem of removing a particular character again & again. Here is VBA code which will automatically remove that special character  from that current sheet of excel.

Sub removeSplchar()
    Dim splchar, tempval, newtempval, newval As String
    Dim cell As Object
    Dim userdefrange As Range
    splchar = InputBox("Enter your spl string:")
    Set userdefrange = ActiveSheet.UsedRange
    On Error Resume Next
    For Each cell In userdefrange
    tempval = cell.Value
        For x = 1 To Len(tempval)
        newtempval = Mid(tempval, x, 1)
            If InStr(newtempval, splchar) = 0 Then
                newval = newval & newtempval
            End If
        Next x
        cell.Value = newval
        newval = ""
    Next cell

End Sub

Login on website using VBA

            Yes!! we can use VBA for web application also.I have faced  a situation where I have to extract sales report  for different locations from web application using different login Id and password. So it's a time comsuming process to login each time with different userid & password. So we can automatize the process using VBA code.

            First of all we have to take two references in Tools menu of VBA Editor

              1. Microsoft HTML object library 

              2.Microsoft Internet Controls

Sample VBA code for this:

Sub loginWebWeX()

Dim htmldoc As HTMLDocument
 Dim browser As InternetExplorer
 Dim surl As String
 Dim objCollection As Object
 Dim objElement As Object
 surl = "https://login.yahoo.com/config/login_verify2?.intl=in&.src=ym"
 On Error GoTo errorhandler
 Set browser = New InternetExplorer
     browser.Silent = True
     browser.navigate surl
     browser.Visible = True
     'MsgBox "Your request is being processed"
     Do While browser.Busy Or browser.ReadyState <> READYSTATE_COMPLETE
                        DoEvents
        Loop
   
    
     Set htmldoc = browser.document
      Set objCollection = htmldoc.getElementsByTagName("Input")
    
                  
     i = 0
     While i < objCollection.Length
    
         If objCollection(i).Name = "username" Then
             objCollection(i).Value = ThisWorkbook.Sheets(1).Range("A1").Value
         ElseIf objCollection(i).Name = "passwd" Then
         objCollection(i).Value = ThisWorkbook.Sheets(1).Range("A2").Value
         End If
         i = i + 1
     Wend
     Set objCollection = Nothing
     Set objCollection = htmldoc.getElementsByTagName("button")
     While j < objCollection.Length
         If objCollection(j).Type = "submit" Then
         Set objElement = objCollection(j)
         objElement.Click
         End If
         j = j + 1
     Wend
    Set objCollection = Nothing
    Set objElement = Nothing
    Set htmldoc = Nothing
    Set browser = Nothing
    Exit Sub
errorhandler:
  MsgBox Err.Description
   
 

End Sub

 

VBA Code for Conditional Coloring of Cell

          Here I am providing you code for conditional coloring of excel cell. This example contains data of Sales Executive,Sales Target and Target Achieved. On clicking on Achiever's List data cells containing more than 90% sales target achieved will be colored.

VBA Code for this as Follows:

Sub selcellbyValue()

Dim salesRange, targetRange As Range

Dim salach, target As Integer

Set salesRange = Application.InputBox("Select Range", "Salesachieved Range", Type:=8)

tempval = 1

For Each cell In salesRange

If cell.Offset(1, 0).Value <> "" Then

salach = cell.Offset(1, 0).Value

target = cell.Offset(1, -1).Value

If (salach / target) > 0.9 Then

cell.Offset(1, 0).Interior.Color = RGB(321, 172, 118)

End If

End If

Next cell

End Sub



Update Data from Multiple Worksheet Using VBA

Let's take there are two files:"Patients.xls & "Report.xls" In first file we collate data for multiple patients(PatientId) monthwise.

In second file we extract data from software for all patients(PatientId) monthwise.

So if there are large no. of patients,it's very difficult to update all monthly data from Report file to Patient file. So here
is the VBA code for update data in Patients.xls from multiple worksheets of Report.xls.

Sub fillRecord()
Dim sheetcount As Integer
Dim filename, sourcemonth As String
Dim wkbook As Workbook
Dim Id, sourceWBC, sourceSodium, sourcePotassium, lookupMonth As Range
On Error Resume Next
filename = "C:\Users\abc\Desktop\vbacodetoupdatedatainmultiplesheet\Report.xls"
sheetcount = Workbooks("Patients.xls").Sheets.Count
Set wkbook = Workbooks.Open(filename)
sourcemonth = Workbooks("Report.xls").Sheets(1).Range("B1").Value
Set Id = Workbooks("Report.xls").Sheets(1).Cells.Find("PatientId", LookIn:=xlValues, lookat:=xlWhole)
Set sourceWBC = Id.EntireRow.Cells.Find("WBC", LookIn:=xlValues, lookat:=xlWhole)
Set sourceSodium = Id.EntireRow.Cells.Find("Sodium", LookIn:=xlValues, lookat:=xlWhole)
Set sourcePotassium = Id.EntireRow.Cells.Find("Potassium", LookIn:=xlValues, lookat:=xlWhole)
For i = 1 To sheetcount
Set lookupMonth = Workbooks("Patients.xls").Sheets(i).Cells.Find(sourcemonth, LookIn:=xlValues, lookat:=xlWhole)
For j = 1 To 3
If Workbooks("Patients.xls").Sheets(i).Name = CStr(Id.Offset(j, 0).Value) Then
lookupMonth.Offset(1, 0).Value = sourceWBC.Offset(j, 0).Value
lookupMonth.Offset(2, 0).Value = sourceSodium.Offset(j, 0).Value
lookupMonth.Offset(3, 0).Value = sourcePotassium.Offset(j, 0).Value
End If
Next j
Next i
End Sub

Dynamic Label Control

      While displaying data in  a label from a database we have to load label control dynamically on a form in VB6. I have generated a simple bill  for a small restaurant.Bill will be generated on selected menu from another form. First form is shown ablove.
Second form is shown below after selecting items

Code for loading dynamic label control with data in Vb6


Option Explicit
Dim i As Integer
Dim lblBill1 As Label
Dim lblBill2 As Label
Dim totalbill As Long
Dim totalAmount As String




Private Sub Form_Load()
Dim parsepamount As String
Dim tempbill As String
'Creating dynamic Control Array
For i = 1 To frmMenu.lstSelectMenu.ListCount
Load lblBill(i)
lblBill(i).Left = 2980
lblBill(i).Top = i * 350
lblBill(i).Visible = True
lblBill(i).Caption = frmMenu.lstSelectMenu.List(i - 1)
parsepamount = Right(lblBill(i).Caption, 3)
tempbill = Trim(parsepamount)
totalbill = CLng(tempbill) + totalbill
'MsgBox (totalbill)
Next
totalAmount = CStr(totalbill)
Set lblBill1 = Controls.Add("Vb.Label", "lblBill1")
lblBill1.Left = 2900
lblBill1.Top = (frmMenu.lstSelectMenu.ListCount + 1) * 350
lblBill1.Visible = True
lblBill1.Caption = "--------------------------"
Set lblBill2 = Controls.Add("Vb.Label", "lblBill2")
lblBill2.Left = 2900
lblBill2.Top = (frmMenu.lstSelectMenu.ListCount + 3) * 350
lblBill2.Visible = True
lblBill2.Caption = "Total Bill: " & totalAmount
totalbill = 0
End Sub