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