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