Class Module Sample Code

Classes are Objects which allow you to group a set of related functionality into one group.The advantage of using classes instead of just subroutines is that classes create a level of abstraction that allow you to write cleaner code. One key indication that you should switch to classes is if you're constantly adding parameters to your functions and subroutines.

A Class can contain:

·        Subs and Functions – generally called Class Methods

       Properties – you can Get and Let these (or Set them if they are Objects)

The Get procedure is used to return a value out of the class, and the Let procedure is to put a value into the class. Note that the return data type of the Get property procedure must be the same data type as the (last) parameter to the Let property procedure. Otherwise, you'll get a compiler error. 

       Events – can be fired

       A Constructor and a Destructor – called Class_Initialize and Class_Terminate.They are called automatically when a Class object is instantiated and destroyed, respectively. You don‘t need to call these Methods; they are called automatically by VBA

       Public Member Variables – can be accessed from outside the class – generally considered bad Object Oriented Design – use Properties instead

       Private Member Variables – can only be accessed inside the class

Sample Code for an Excel VBA Classes:

In the VBA editor, go to Insert > Class Module. In the Properties window (bottom left of the screen by default), change the name of the module to WorkLogItem. Add the following code to the class:

Option Explicit

Private pTaskID As Long
Private pPersonName As String
Private pHoursWorked As Double

Public Property Get TaskID() As Long
    TaskID = pTaskID
End Property

Public Property Let TaskID(lTaskID As Long)
    pTaskID = lTaskID
End Property

Public Property Get PersonName() As String
    PersonName = pPersonName
End Property

Public Property Let PersonName(lPersonName As String)
    pPersonName = lPersonName
End Property

Public Property Get HoursWorked() As Double
    HoursWorked = pHoursWorked
End Property

Public Property Let HoursWorked(lHoursWorked As Double)
    pHoursWorked = lHoursWorked
End Property

Let's keep moving with this example. Instead of storing the objects in array, we'll try using acollection.

Next, add a new class module and call it ProcessWorkLog. Put the following code in there:

Option Explicit

Private pWorkLogItems As Collection

Public Property Get WorkLogItems() As Collection
    Set WorkLogItems = pWorkLogItems
End Property

Public Property Set WorkLogItems(lWorkLogItem As Collection)
    Set pWorkLogItems = lWorkLogItem
End Property

Function GetHoursWorked(strPersonName As String) As Double
    On Error GoTo Handle_Errors
    Dim wli As WorkLogItem
    Dim doubleTotal As Double
    doubleTotal = 0
    For Each wli In WorkLogItems
        If strPersonName = wli.PersonName Then
            doubleTotal = doubleTotal + wli.HoursWorked
        End If
    Next wli

Exit_Here:
    GetHoursWorked = doubleTotal
        Exit Function

Handle_Errors:
        'You will probably want to catch the error that will '
        'occur if WorkLogItems has not been set '
        Resume Exit_Here


End Function

The above class is going to be used to "do something" with a colleciton of WorkLogItem. Initially, we just set it up to count the total number of hours worked. Let's test the code we wrote. Create a new Module (not a class module this time; just a "regular" module). Paste the following code in the module:

Option Explicit

Function PopulateArray() As Collection
    Dim clnWlis As Collection
    Dim wli As WorkLogItem
    'Put some data in the collection'
    Set clnWlis = New Collection

    Set wli = New WorkLogItem
    wli.TaskID = 1
    wli.PersonName = "Fred"
    wli.HoursWorked = 4.5
    clnWlis.Add wli

    Set wli = New WorkLogItem
    wli.TaskID = 2
    wli.PersonName = "Sally"
    wli.HoursWorked = 3
    clnWlis.Add wli

    Set wli = New WorkLogItem
    wli.TaskID = 3
    wli.PersonName = "Fred"
    wli.HoursWorked = 2.5
    clnWlis.Add wli

    Set PopulateArray = clnWlis
End Function

Sub TestGetHoursWorked()
    Dim pwl As ProcessWorkLog
    Dim arrWli() As WorkLogItem
    Set pwl = New ProcessWorkLog
    Set pwl.WorkLogItems = PopulateArray()
    Debug.Print pwl.GetHoursWorked("Fred")

End Sub

Why is this helpful?

Let's suppose your data changes and you want to add a new method. Suppose your WorkLogItemnow includes a field for HoursOnBreak and you want to add a new method to calculate that.

All you need to do is add a property to WorkLogItem like so:

Private pHoursOnBreak As Double

Public Property Get HoursOnBreak() As Double
    HoursOnBreak = pHoursOnBreak
End Property

Public Property Let HoursOnBreak(lHoursOnBreak As Double)
    pHoursOnBreak = lHoursOnBreak
End Property

Pop-up calendar using Active X Control

Open the file Personal.xls

    Then Insert a Userform
    Then change properties of Userform with
    Name :frmCalendar
    Caption: Select a Date

Then go to View >Toolbox>Tools>Additional Controls and choose Calendar Control(Active X control)

Next add a command button.

Place the Command button on Userform.

Do the following changes in properties window
Name: cmdClose
Cancel: True


VBA code for Commandbutton:

    private sub cmdClose_Click()

        Unload Me

    End sub

VBA code for Calendar control



    Private sub Calendar1_Click()

    Activecell.value=Calendar1.value
    Unload me
   

End sub


Then Insert module and create a macro


    sub openCalendar()
        frmCalendar.Show
       
    End sub



In Personal.xls, click office button.Then click Excel Options.

Then choose Customised option.

Choose Macros from Command drop-down.

Add Macro Opencalendar() to quick access toolbar.

Then do double click on OK button.

VBA Code Casestudy:Automated V-lookup

In our office we have a huge database of sub-publisher group,we need to enter in excel worksheet and their corresponding publisher name. Here is a VBA code who matches sub-publisher from active workbook to Master data file of sub publisher's and give their corresponding publisher's name  in respective column
VBA code using v-lookup is as  mentioned below:



Function automatedVlookup()
    Dim pathname, vlookupformula, bookname, sheetname As String
    Dim displaycolumn As Integer
    Dim wb  As Workbook
    Dim mywb As String
 
    Dim myrng, displayrange, lookuprange  As Range
    Application.ScreenUpdating = False
    Dim cntrow, tempcount As Long
 
 
    On Error Resume Next
 
    'Selecting columnno. of Publisher name
 
 
     mywb = CStr(ActiveWorkbook.Name)
    'counting total no. of rows
     cntrow = ActiveWorkbook.Sheets(1).UsedRange.Rows.Count
 
    'selecting column of publisher subgroup
    Set myrng = Application.InputBox("Select column", "Sub publisher group", Type:=8)
    displaycolumn = CInt(Application.InputBox("Select column no. you want to display", "for Publisher group", Type:=2))
 
   
        pathname = frmfinal.temppathname.Value & "\pub group_new.xls"
     
        'openning publisher master file
     
        Set wb = Workbooks.Open(pathname)
       
        If Not wb Is Nothing Then
         
            Set lookuprange = wb.Sheets(1).UsedRange
            bookname = "pub group_new.xls"
            sheetname = wb.Sheets(1).Name
     
        tempcount = 1
 
            Do
                    Set myrng = myrng.Offset(1, 0)
                    Set displayrange = myrng
         
                    'setting lookup formula
                    vlookupformula = "=if(iserror(vlookup(" & CStr(myrng.Address) & ",'[" & bookname & "]" & sheetname & "'!" & CStr(lookuprange.Address) & ",2,0))," & Chr(34) & Chr(34) & "," & "vlookup(" & CStr(myrng.Address) & ",'[" & bookname & "]" & sheetname & "'!" & CStr(lookuprange.Address) & ",2,0))"
             
             
                    'writing vlookup formula
         
                    displayrange.Offset(0, displaycolumn).Formula = vlookupformula
             
                    tempcount = tempcount + 1
            Loop Until tempcount = cntrow
        Else
     
            MsgBox "Publisher file Not found"
        End If
        wb.Close savechanges:=False
        Set wb = Nothing
        Unload frmfinal
        Application.ScreenUpdating = True
 

End Function

VBA Code for Google Search Engine

Automatic Openning of Google Search Engine through VBA Code:



Option Explicit
Sub googleSearch()
Dim browser As New InternetExplorer
Dim htmldoc As HTMLDocument
Dim url As String
Dim i, j As Integer
Dim objcollection, objelement As Object

    Application.ScreenUpdating = False
    On Error GoTo Errorhandler
    url = "http://www.google.co.in"
    browser.navigate url
    browser.Visible = True
    MsgBox "Your data is being searched"
    MsgBox "Chck1"
    Set htmldoc = browser.document
    Set objcollection = htmldoc.getElementsByTagName("Input")
        MsgBox "Chck2"
        While i < objcollection.Length
                If objcollection(i).Name = "q" Then
                MsgBox "Chck3"
                    objcollection(i).Value = Range("A2").Value
           
                End If
                MsgBox "Chck4"
            i = i + 1
        Wend
    Set objcollection = Nothing
    Set objcollection = htmldoc.getElementsByTagName("button")
    MsgBox "Chck5"
        While j < objcollection.Length
            If objcollection(j).Type = "submit" Then
                    Set objelement = objcollection(j)
                    objelement.Click
            End If
         MsgBox "Chck6"
           j = j + 1
        Wend
        Set objelement = Nothing
        Set objcollection = Nothing
        Set htmldoc = Nothing
        Set browser = Nothing
        Application.ScreenUpdating = True
    Exit Sub
Errorhandler:
    MsgBox "Error" & Err.Description
End Sub

Creating Worksheet Calendar through VBA

VBA code for creating a Calendar in Excel Worksheet

Option Explicit

Sub createClaendar()

Dim lmonth, ldays As Long

Dim strmonth, straddress As String

Dim myrng, mycell As Range

Dim mydate As Date

    Application.ScreenUpdating = False

    On Error Resume Next

    'removing grid lines in excel sheet

    ActiveWindow.DisplayGridlines = False

    'Fixing cells size

    With Cells

        .ColumnWidth = 6

        .Font.Size = 8

    End With

    'Select quaterly month's name in row wise

    For lmonth = 1 To 4

        Select Case lmonth

            Case 1

                strmonth = "January"

                Set myrng = Range("A1")

            Case 2

                strmonth = "April"

                Set myrng = Range("A8")

            Case 3

                strmonth = "July"

                Set myrng = Range("A15")

            Case 4

                strmonth = "October"

                Set myrng = Range("A22")

        End Select

        'Entering month's name

        With myrng

            .Value = strmonth

            .Font.Bold = True

            .Interior.ColorIndex = 22

                With .Range("A1:G1")

                     .Merge

                     .BorderAround LineStyle:=xlContinuous

                End With

                'seleting months rowwise

            .Range("A1:G1").AutoFill Destination:=.Range("A1:U1")

        End With

        

        

    

      Next lmonth

      lmonth = 1

      For lmonth = 1 To 12

      straddress = Choose(lmonth, "A2:G7", "H2:N7", "O2:U7", "A9:G14", "H9:N14", "O9:U14", "A16:G21", "H16:N21", "O16:U21", _

                "A23:G28", "H23:N28", "O23:U28")

      ldays = 0

            For Each mycell In Range(straddress)

              ldays = ldays + 1

              mydate = DateSerial(Year(Date), lmonth, ldays)

                  If Month(mydate) = lmonth Then

                      'fill each month's range

                          With mycell

                             .Value = DateSerial(Year(Date), lmonth, ldays)

                             .NumberFormat = "ddd dd"

                          End With

                  End If

            Next mycell

      Next lmonth

    

End Sub

Convert Excel Sheet to HTML

Option Explicit
Sub converttoHtml()
Dim myrng As Range
Dim temppathname As String
Dim tempwb As Workbook
Set myrng = ActiveSheet.UsedRange
On Error Resume Next
Application.ScreenUpdating = False
temppathname = Environ("temp") & "/" & Format(Date, "mm-dd-yy") & ".htm"
myrng.Copy
Set tempwb = Workbooks.Add(1)
    With tempwb.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial.xlPasteFormats , , False, False
        ActiveWorkbook.Save
    End With
    With tempwb.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
         Filename:=temppathname, _
         Sheet:=tempwb.Sheets(1).Name, _
         Source:=tempwb.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set tempwb = Nothing
    Set myrng = Nothing
End Sub

Acces VBA Macro from another Excel File

If you want to access VBA Macro from another Excel file Code is as follows:




Option Explicit
Sub accessotherMacro()
Dim pathname As String
Application.ScreenUpdating = False
Dim wb As Workbook
On Error Resume Next
pathname = "C:\Users\abc\Desktop\mybook1.xls"
MsgBox Dir(pathname)
On Error Resume Next
        If Not Dir(pathname) = vbNullString Then
            Set wb = Workbooks.Open(pathname)
            Application.Run (wb.Name & "!test")
        ElseIf Dir(pathname) = vbNullString Then
            MsgBox "File doesnot Exist"
        End If
Application.ScreenUpdating = True




End Sub

Caculation of Age from DoB

It's a simple code for calculation of one's age in terms of year,monh and days





Sub calculateAge()
Dim mydob As Date, tempdob As Date, sysdate As Date
Dim y As Integer, m As Integer, d As Integer
mydob = CDate(Application.InputBox("Enter your DoB", "DoB", Default:=Format(Date, "mm/dd/yyyy"), Type:=2))
sysdate = Format(Date, "mm/dd/yyyy")
tempdate = DateSerial(Year(sysdate), Month(mydob), Day(mydob))
    If (tempdate > sysdate) Then
        y = (Year(tempdate) - Year(mydob)) - 1
        If Day(mydob) > Day(sysdate) Then
             m = -Month(mydob) - 12 * (tempdate > sysdate) + Month(sysdate) - 1
             sysdate = DateSerial(Year(sysdate), Month(sysdate), 0)
             d = Day(sysdate) - Day(mydob) + Day(Date)

        ElseIf Day(mydob) < Day(sysdate) Then
            m = -Month(mydob) - 12 * (tempdate > sysdate) + Month(sysdate)
            d = Day(Date) - Day(mydob)
     

        End If
     ElseIf (tempdate < sysdate) Then
            y = (Year(tempdate) - Year(mydob))
        If Day(mydob) > Day(sysdate) Then
             m = Month(Date) - Month(mydob) - 1
             sysdate = DateSerial(Year(sysdate), Month(sysdate), 0)
             d = Day(sysdate) - Day(mydob) + Day(Date)

        ElseIf Day(mydob) < Day(sysdate) Then
            m = -Month(mydob) - 12 * (tempdate > sysdate) + Month(sysdate)
            d = Day(Date) - Day(mydob)
     

        End If
    End If
   MsgBox "Your age  is" & y & " Years " & m & " months " & d & "days"
End Sub

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