Charts Dashboard

Charts

Install SQL Server 2012

Install SQL Server 2012

Alternative to ADO (Using Web Service)

On clicking refresh button; it asks for PINCode. On entering PINCode, it shows 10 rows data points(location) within 10 km surroundings using a web service(Alternative to  hitting database with ADO)





Sub findLocation()

    Dim xmlhtp As New MSXML2.XMLHTTP60
    Dim Parameter1 As String, baseurl As String
    Dim xmlDoc As New DOMDocument60
    Dim nodeList As IXMLDOMNodeList
    Dim node As IXMLDOMNode, pincode As String
    Dim rowcount As Long
    Dim location As String, city As String, pcode As String
    ThisWorkbook.Sheets(1).Range("A3") = "City"
    ThisWorkbook.Sheets(1).Range("B3") = "Location"
    ThisWorkbook.Sheets(1).Range("C3") = "PINCode"
    rowcount = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    If (rowcount > 3) Then
        ThisWorkbook.Sheets(1).Range("A4:C" & rowcount).ClearContents
        ThisWorkbook.Sheets(1).Range("A4:C" & rowcount).Interior.ColorIndex = xlNone
        ThisWorkbook.Sheets(1).Range("A4:C" & rowcount).Borders.LineStyle = xlNone
   
    End If
    rowcount = 3
    'taking input paramater PINCODE
    pincode = Application.InputBox("Please enter Pincode to search Location", "PINCode", Type:=2)
    'webService
    baseurl = "http://api.geonames.org/findNearbyPostalCodes?postalcode=" & pincode & "&country=In&radius=10&username=somu&maxRows=10"
 
    With xmlhtp
    'GET is simpler and faster than POST, and can be used in most cases.
    'However, always use POST requests when:
    'A cached file is not an option (update a file or database on the server)
    'Sending a large amount of data to the server (POST has no size limitations)
    'Sending user input (which can contain unknown characters), POST is more robust and secure than GET
        .Open "POST", baseurl, False
     
        'Requests that are being sent are based on two parts: the Header and the Body.
        'The Header contains information about the Body so that the receiver knows what data is contained there.
        .setRequestHeader "Content-Type", "text/xml;"
        'Sends an HTTP request to the server and receives a response. oXMLHttpRequest.send(varBody)
        'varBody [optional]--The body of the message being sent with the request.
        'This method is synchronous or asynchronous, depending on the value of the bAsync parameter in the open method call.
        'If open is called with bAsync == False, this call does not return until the entire response is received or the protocol
        'stack times out. If open is called with bAsync == True, this call returns immediately.
        .send
        xmlDoc.LoadXML .responseText
        Set nodeList = xmlDoc.SelectNodes("/geonames/code")
        For Each node In nodeList
         
            location = node.SelectSingleNode("name").Text
            city = node.SelectSingleNode("adminName1").Text
            pcode = node.SelectSingleNode("postalcode").Text
            ThisWorkbook.Sheets(1).Range("B" & (rowcount + 1)) = (location)
            ThisWorkbook.Sheets(1).Range("A" & (rowcount + 1)) = (city)
            ThisWorkbook.Sheets(1).Range("C" & (rowcount + 1)) = (pcode)
            rowcount = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
        Next node
        ThisWorkbook.Sheets(1).Columns("A:C").AutoFit
        ThisWorkbook.Sheets(1).Range("A4:C" & rowcount).Interior.ColorIndex = 20
        ThisWorkbook.Sheets(1).Range("A4:C" & rowcount).Borders.LineStyle = xlContinuous
        ThisWorkbook.Sheets(1).Range("A3:C3").Interior.ColorIndex = 37
        ThisWorkbook.Sheets(1).Range("A3:C3").Font.Bold = True
    End With

 
         
 

End Sub



Download File

Bubble Sort in Collection VBA

'Sorting Collection in VBA
    For l = 1 To mycoll1.Count - 1
           'MsgBox mycoll1(l)
            For m = l + 1 To mycoll1.Count
                       
            If (IsNumeric(Mid(mycoll1(l), 1, 2))) And (IsNumeric(Mid(mycoll1(m), 1, 2))) Then
                    If CInt(Mid(mycoll1(l), 1, 2)) > CInt(Mid(mycoll1(m), 1, 2)) Then
                     'store the lesser item
                         mycoll1temp = mycoll1(m)
                     'remove the lesser item
                         mycoll1.Remove m
                      're-add the lesser item before the
                    'greater Item
                         mycoll1.Add mycoll1temp, mycoll1temp, l
                     End If
            ElseIf (IsNumeric(Mid(mycoll1(l), 1, 2))) And (IsNumeric(Mid(mycoll1(m), 1, 1))) Then
                    If CInt(Mid(mycoll1(l), 1, 2)) > CInt(Mid(mycoll1(m), 1, 1)) Then
                     'store the lesser item
                         mycoll1temp = mycoll1(m)
                     'remove the lesser item
                         mycoll1.Remove m
                      're-add the lesser item before the
                    'greater Item
                         mycoll1.Add mycoll1temp, mycoll1temp, l
                     End If
            ElseIf (IsNumeric(Mid(mycoll1(l), 1, 1))) And (IsNumeric(Mid(mycoll1(m), 1, 2))) Then
                    If CInt(Mid(mycoll1(l), 1, 1)) > CInt(Mid(mycoll1(m), 1, 2)) Then
                     'store the lesser item
                         mycoll1temp = mycoll1(m)
                     'remove the lesser item
                         mycoll1.Remove m
                      're-add the lesser item before the
                    'greater Item
                         mycoll1.Add mycoll1temp, mycoll1temp, l
                        
                     End If
            ElseIf (IsNumeric(Mid(mycoll1(l), 1, 1))) And (IsNumeric(Mid(mycoll1(m), 1, 1))) Then
                    If CInt(Mid(mycoll1(l), 1, 1)) > CInt(Mid(mycoll1(m), 1, 1)) Then
                     'store the lesser item
                         mycoll1temp = mycoll1(m)
                     'remove the lesser item
                         mycoll1.Remove m
                      're-add the lesser item before the
                    'greater Item
                         mycoll1.Add mycoll1temp, mycoll1temp, l
                        
                     End If
           
            End If
            Next
           
    Next

Vba Code to Count Visible Rows After Autofiltering a Excel Sheet

tempwb.Sheets(1).Range("B2:B" & temprowcount).SpecialCells(xlCellTypeVisible).Rows.Count

MOD Function

http://www.get-digital-help.com/2014/06/03/learn-how-the-mod-function-works/

Moving Average Chart

http://www.get-digital-help.com/2015/11/03/follow-stock-market-trends-moving-average/

Updating Data Using Cursor in VBA

Option Private Module
Option Explicit
Dim conn As ADODB.Connection, dateval As String, day As String, month As String, Yr As String
Dim empCode As String
Dim rst As ADODB.Recordset, querystring, i As Integer, rowcount As Long

Sub updateempDetailsForOracle()
Set conn = New ADODB.Connection
Set rst = New ADODB.Recordset
dateval = ThisWorkbook.Sheets(1).Range("A1")
empCode = ThisWorkbook.Sheets(1).Range("A2")
If InStr(Mid(dateval, 1, 2), "/") > 0 Then
        day = Mid(dateval, 1, 1)
        month = Mid(dateval, 3, 1)
        Yr = Mid(dateval, 5, 4)
Else
        day = Mid(dateval, 1, 2)
        month = Mid(dateval, 4, 2)
        Yr = Mid(dateval, 7, 4)

End If

querystring = "update empDetails set empDOJ=" & Chr(39) & Yr & "-" & month & "-" & day & Chr(39) & " where empCode=" & empCode
i = 1
rowcount = ThisWorkbook.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
If (rowcount > 1) Then
        ThisWorkbook.Sheets(1).Range("A2:B" & rowcount).ClearContents
End If
    conn.ConnectionString = "Data Source=empDetails;Initial Catalog=dbMentorMenteedetails;uid="*";pwd="*"
    conn.CursorLocation = adUseServer
    conn.Open
    rst.Open querystring, conn, adOpenDynamic
       
        conn.Close
        Set rst = Nothing
        Set conn = Nothing
End Sub

Check Directory Exists If Not Create

Dim pathname As String, tripid As String, respCreate
Sub ChecknCreateDirectory()
tripid = "12"
pathname = "C:\Users\" & Environ("username") & "\Google Drive\" & tripid
   If (Len(Dir(pathname, vbDirectory)) = 0) Then
         rspCreate = MsgBox("Directory doesn't exist, do you wish to create it?", vbYesNo)
            If (rspCreate = vbYes) Then
                MkDir "C:\Users\" & Environ("username") & "\Google Drive\" & tripid
            End If
    End If
End Sub

Create Pivot Table Using CTE

http://sqlmag.com/t-sql/create-pivoted-tables-3-steps

CTE

http://blog.sqlauthority.com/2009/08/08/sql-server-multiple-cte-in-one-select-statement-query/

Extracting Data using Cursor in VBA

Option Private Module
Option Explicit
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset, querystring, i As Integer, rowcount As Long
'get employeelis for Oracle Domain
Sub getempDetailsForOracle()
Set conn = New ADODB.Connection
Set rst = New ADODB.Recordset
querystring = "Select tbemp.empCode,tbemp.empName from empDetails tbemp join tbldomainList tbdom on " _
& "tbemp.empDomainId=tbdom.domainId  where tbdom.domainId=8"
i = 1
rowcount = ThisWorkbook.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
If (rowcount > 1) Then
        ThisWorkbook.Sheets(1).Range("A2:B" & rowcount).ClearContents
End If
    conn.ConnectionString = "Data Source=empDetails;Initial Catalog=*;uid=*;pwd=*"
    conn.CursorLocation = adUseClient
    conn.Open
    rst.Open querystring, conn, adOpenStatic
        Do While Not rst.EOF
        i = i + 1
             ThisWorkbook.Sheets(1).Range("A" & i) = rst.Fields(0).Value
             ThisWorkbook.Sheets(1).Range("B" & i) = rst.Fields(1).Value
                rst.MoveNext
        Loop
        rst.Close
        conn.Close
        Set rst = Nothing
        Set conn = Nothing
End Sub

Setting SQL Server 2008 Authentication New Login

https://www.supremainc.com/en/node/618

Create a Login for SQL Server 2008

https://msdn.microsoft.com/en-in/library/aa337562.aspx

get ServerName in SQL

SELECT @@SERVERNAME;

Create Custom Events using Withevents in VBA

WithEvents specifies that one or more declared member variables refer to an instance of a'
class that can raise events. WithEvents connects the event system to the  variable and
lets you utilize the events of the object.

In this example; we have raised cellSelect event. On selection of value in "A1"; we can
get cell name, cell address, colorindex and cell content in column B,C,D,E.

Steps:
 1.Declare a variable with  WithEvents and classname in Sheet where we need to raise
events.

 2.Write attributes and methods in a class, There are three attributes, for selecting
range, cell name, &set color and one method for setting color in selected range.

3.Declare 3 variables for three attributes for selected range, color and name.

4.Declare an event cellSelect.

5.RaiseEvent inside set property for selected Range.

6.Write a method named methodColor for assigning colorindex to a selected cell.

              Dim rngVar As Range
              Dim intColor As Integer
              Dim strName As String

              Public Event cellSelect(cell As Range)

   Public Property Set selectedRng(objVar As Range)
            Set rngVar = objVar
            RaiseEvent cellSelect(rngVar)
   End Property

   Public Property Get selectedRng() As Range
          Set selectedRng = rngVar
   End Property

  Public Property Let Name(objName As String)

         strName = objName
  End Property

  Public Property Get Name() As String
         Name = strName
  End Property

  Public Property Let Color(objColor As Integer)
        intColor = objColor

  End Property
  Public Property Get Color() As Integer
         Color = intColor
  End Property

  Sub methodColor()

        selectedRng.Interior.ColorIndex = Color

  End Sub

7.Now write an event procedure rng_cellSelect

8.Now assign  selected Range under Private Sub
  Worksheet_SelectionChange(ByVal Target As Range)




Private WithEvents rng As clsWithEvents
Dim i As Integer
Private Sub rng_cellSelect(cell As Range)
    rng.Color = 24
    If (rng.Color < 1) And (rng.Color > 56) Then
            MsgBox "Error! please enter a color index between 1 and 56"
    End If
        rng.Name = "First Cell"
        rng.methodColor
        rng.selectedRng.Select
        i = rng.Color
        Selection.Offset(0, 1).Value = "Name: " & rng.Name
        Selection.Offset(0, 2).Value = "Address:  " & Selection.Address
        Selection.Offset(0, 3).Value = "Interior color Index:  " & i
        Selection.Offset(0, 4).Value = "Cell Content  " & Selection.Value
       
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        Set rng = New clsWithEvents
       
            If (Target.Address = Range("A1").Address) Then
                Set rng.selectedRng = Target
           
           
            End If
End Sub
Download File

Extract Data from MS Access 2010 to Excel using ADODB Connection

Option Explicit
Dim conn As ADODB.Connection, i As Integer
Dim rst As ADODB.Recordset, querystring As String
Sub accesData()
Set conn = New ADODB.Connection
Set rst = New ADODB.Recordset
i = 1
querystring = "Select [Order Id], sum(([Unit Price]*Quantity))  as Sales  from [Order Details] group  by [Order Id]"
conn.ConnectionString = "Provider=Microsoft.Access.OLEDB.10.0;Persist Security Info=False;Data Source=somu"
conn.Open
conn.CursorLocation = adUseClient
rst.Open querystring, conn, adOpenStatic
    Do While Not rst.EOF
        ThisWorkbook.Sheets(1).Range("A" & (i + 1)) = rst.Fields(0).Value
        ThisWorkbook.Sheets(1).Range("B" & (i + 1)) = rst.Fields(1).Value
        rst.MoveNext
        i = i + 1
    Loop
rst.Close
conn.Close
Set rst = Nothing
Set conn = Nothing
End Sub


Download Excel

Sample Database

Create and Populate ListBox from MSSQL Database

Set conn = New ADODB.Connection
    Set rst = New ADODB.Recordset
   
    conn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Data Source=.;Initial Catalog=CourseMasterDB;"
    conn.Open
    querystring = "Select GeoName from MST_Geo"
    i = 0
    k = 3
   
           
            rst.Open querystring, conn, adOpenStatic
            ReDim geoArray(rst.RecordCount)
            Do While Not rst.EOF
            geoArray(i) = rst.Fields(0).Value
            rst.MoveNext
            i = i + 1
            Loop
   
            rst.Close
            conn.Close
            Set rst = Nothing
            Set conn = Nothing
           For k = 3 To ThisWorkbook.Sheets.Count
                            Set lookuprng = ThisWorkbook.Sheets(k).Columns("J:J").Find("Select GEO", LookIn:=xlValues, lookat:=xlWhole)
                            If (Not lookuprng Is Nothing) Then
                             ThisWorkbook.Sheets(k).Range(lookuprng.Address).ClearContents
                             ThisWorkbook.Sheets(k).Range(lookuprng.Offset(0, 1).Address).Validation.Delete
                            End If
                            rowcount = ThisWorkbook.Sheets(k).Range("J" & Rows.Count).End(xlUp).Row
                            ThisWorkbook.Sheets(k).Range("J" & (rowcount + 15)) = "Select GEO"
                            ThisWorkbook.Sheets(k).Range("J" & (rowcount + 15)).FontSize = 15
                            ThisWorkbook.Sheets(k).Range("J" & (rowcount + 15)).Interior.ColorIndex = 24
                         With ThisWorkbook.Sheets(k).Range("K" & (rowcount + 15)).Validation
                             .Delete
                             .Add Type:=xlValidateList, Formula1:=Join(geoArray, ",")
                             .InCellDropdown = True
                             .InputTitle = ""
                             .ErrorTitle = ""
                             .InputMessage = ""
                             .ErrorMessage = ""
                             .ShowInput = True
                             .ShowError = True
                        End With

Add Form Control CheckBox in VBA

objrng.Offset(k, 0) = rst.Fields(0).Value
                'add check box
                ThisWorkbook.Sheets(shtcnt).CheckBoxes.Add(Left:=objrng.Offset(k, 1).Left, Top:=objrng.Offset(k, 1).Top, Width:=objrng.Offset(k, 1).Width, Height:=objrng.Offset(k, 1).Height).Select
                ThisWorkbook.Sheets(shtcnt).Range(objrng.Offset(k, 1).Address).NumberFormat = ";;;"
                With Selection
               
                    .Caption = ""
                    .Name = ""
               
                    .LinkedCell = objrng.Offset(k, 1).Address
                End With

Using ShellExecute to open an .exe File

Public Declare Function ShellExecute _
    Lib "shell32.dll" _
        Alias "ShellExecuteA" ( _
            ByVal Hwnd As Long, _
            ByVal lpOperation As String, _
            ByVal lpFile As String, _
            ByVal lpParameters As String, _
            ByVal lpDirectory As String, _
            ByVal nShowCmd As Long) _
As Long
Sub my_Procedure()
pathname = "C:\Program Files (x86)\TechSmith\Camtasia Studio 8\CamRecorder.exe"


'ThisWorkbook.Windows(1).WindowState = xlMinimized
procId = ShellExecute(0, "Open", pathname, vbNullString, "C:\", SW_SHOWNORMAL)
Application.Wait (Now + TimeValue("00:00:03"))
'AppActivate procId
Application.SendKeys ("{F9}"), True


end Sub