Amazing Excel VBA Creativity

I found below excel workbooks during learning excel VBA
you can download workbook from below links

• Painting in Excel 

         http://www.mediafire.com/?4aythpdtaj7irkm

         http://www.mediafire.com/file/hoe2pxsx1hdd0q6/Excel VBA_Painting In Excel.xls

       

• Excel VBA MP3 Player

         http://www.mediafire.com/file/q9hjmticqx0cyc1/Excel VBA-MP3-Player.xls

• Find Internet Browsing History in Excel sheet

        http://www.mediafire.com/file/bz7q8jf47b57za9/Excel VBA -Find Internet History.xlsb

Greetings in Excel

I have received amazing  response for New year greeting wishes in excel from all who seen them around the world

• valentine's day greeting cards in Excel

          http://www.mediafire.com/?7f4lhrwya97xzlf

• happy new year greetings in Excel

          http://www.mediafire.com/?9filaap09h4gqgq

          http://www.mediafire.com/?a5k4acw114g90s6

Excel : Find duplicate entry while entering data in column

For any column in worksheet .This will give you alert while entering duplicate entry with msg box & column header name. highlight the duplicate entry

Right click on sheet tab-> view code->copy below code


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Application.WorksheetFunction.CountIf(Range(Cells(2, Target.Column), Cells(Target.Row, Target.Column)), Target) > 1 Then
     Alert = MsgBox(Cells(1, Target.Column) & " Already Exist - Click Yes do delete", vbYesNo)
     If Alert = vbYes Then
     Application.Undo
     Else
     Target.Interior.ColorIndex = 6
     Exit Sub
     End If
End If
End Sub

Excel Find and Highlight Maximum Value from Each Column

this will highlight maximum value from each column in worksheet

Sub Mtest()
Dim c As Range, rng As Range
Dim lCol As Long, LR As Long
With ActiveSheet
    For lCol = 1 To .UsedRange.Columns.Count
      LR = .Cells(.Rows.Count, lCol).End(xlUp).Row
      Set rng = .Range(.Cells(1, lCol), .Cells(LR, lCol))
      For Each c In rng
        If c.Value = Application.WorksheetFunction.Max(rng) Then
          c.Interior.ColorIndex = 3
        Else
          c.Interior.ColorIndex = xlNone
        End If
      Next
    Next lCol
  End With
End Sub

Excel : Open list of website & download data

this requirement came from my friend. He used to open list of websites & download the NAV.
you can download data from web page through web query


Sub Mtest()
Dim page As New InternetExplorer
For i = 2 To Sheets("websitelist").Range("A" & Rows.Count).End(xlUp).Row
URL = Sheets("websitelist").Cells(i, 1)
page.Navigate URL '
page.Visible = True
Do
Loop Until page.ReadyState = READYSTATE_COMPLETE
page.Refresh
'=============================
'call your web query here
'=============================
page.Quit
'if you dont use below line you will get error like
'The remote server machine does not exist or is unavailable
'This quits page and releases the object.
Set page = Nothing
Next i
End Sub

Excel : Login to Gmail /Yahoomail with Vba

Press Alt + F11
Go to tools->References
select below references & click ok

• Microsoft Internet Controls
• Microsoft HTML Object Liabrary

Gmail

Dim HTMLDoc As HTMLDocument
Dim oBrowser As InternetExplorer
Sub Login_GMAIL()

Dim oHTML_Element As IHTMLElement
Dim sURL As String
On Error GoTo Err_Clear
sURL = "https://www.gmail.com"
Set oBrowser = New InternetExplorer
oBrowser.Silent = True
oBrowser.timeout = 60
oBrowser.navigate sURL
oBrowser.Visible = True
Do
' Wait till the Browser is loaded
Loop Until oBrowser.readyState = READYSTATE_COMPLETE
Set HTMLDoc = oBrowser.document
HTMLDoc.all.Email.Value = "abc@gmail.com" 'Enter your gmail id here
HTMLDoc.all.passwd.Value = "abc@1234" 'Enter your password here
For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
If oHTML_Element.Type = "submit" Then oHTML_Element.Click: Exit For
Next
' oBrowser.Refresh ' Refresh If Needed
Err_Clear:
If Err <> 0 Then
'Debug.Assert Err = 0
Err.Clear
Resume Next
End If
End Sub

'Open login page of Gmail and go to view source you will get below javascript
'<label>
  '<strong class="email-label">Username</strong>
  '<input type="text" spellcheck="false" name="Email" id="Email" value="">
'</label>
'<label>
  '<strong class="passwd-label">Password</strong>
  '<input type="password" name="Passwd" id="Passwd">
'</label>

Yahoomail


Dim HTMLDoc As HTMLDocument
Dim oBrowser As InternetExplorer
Sub Login_YAHOO()

Dim oHTML_Element As IHTMLElement
Dim sURL As String
On Error GoTo Err_Clear
sURL = "https://login.yahoo.com"
Set oBrowser = New InternetExplorer
oBrowser.Silent = True
oBrowser.timeout = 60
oBrowser.navigate sURL
oBrowser.Visible = True
Do
Loop Until oBrowser.readyState = READYSTATE_COMPLETE
Set HTMLDoc = oBrowser.document
HTMLDoc.all.login.Value = "mahesh" 'Enter your yahoo id here
HTMLDoc.all.passwd.Value = "abc" 'Enter your password here
For Each oHTML_Element In HTMLDoc.getElementsByTagName("button")
If oHTML_Element.Type = "submit" Then oHTML_Element.Click: Exit For
Next
Err_Clear:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub
'<label for='username'>Yahoo! ID</label>
'<input name='login' id='username' maxlength='96' tabindex='1' value=''>
'<label for='passwd'>Password</label>
'<input name='passwd' id='passwd' type='password' maxlength='64' tabindex='2'>

Excel VBA Learning - (MOS) 2010 Study Guide for Microsoft® Excel

• Excel 2007 VBA Macro Programming 

• Microsoft Office Specialist (MOS) 2010 Study Guide for Microsoft® Excel 

• Vba_for_Excel_Made_Simple_(Made_Simple_Programming)