Extract particular text from Hyperlink

For example we have a website http://www.amazon.com/Best-Sellers-Books-Architectural-Art-Design/zgbs/books/5005940011/ref=zg_bs_nav_b_2_1 linked to a cell hyperlink in an excel data. From where we need to extract only  5005940011. VBA code for this objective is as follows:


Dim myurl As String
Dim tempval, tempvalnew, nodeid As String

Sub searchVal()

myurl = ActiveCell.Hyperlinks(1).Address


For x = 1 To Len(myurl)
tempval = Mid(myurl, x, 1)

    If InStr(tempval, "/") <> 0 Then
    counter = counter + 1
 
    End If
    If (counter = 6 And tempval <> "/") Then
     
        nodeid = nodeid & tempval
     
    ElseIf counter = 7 Then
    ActiveCell.Offset(0, 1).Value = nodeid
    nodeid = vbNullString
    myurl = vbNullString
        Exit Sub

    End If
 
Next x



End Sub

Timer in Excel using VBA

Public Sub TestTimer()
MsgBox "The timer will switch off in 10 seconds!"
MsgBox ("Currenttime: " & Now)
alertTime = Now + TimeValue("00:00:10")
Application.OnTime alertTime, "TestTimer"
myMacro
End Sub

Determine a Cell in Specified Range or Not

Double click any sheet in VBA Project Explorer and paste following code:

Private Sub Worksheet_SelectionChange(ByVal target As Range)
If Not Intersect(target, Range("myrange")) Is Nothing Then
MsgBox target.Address & "is in myrange"
Else
MsgBox target.Address & "is not in myrange"
End If
End Sub

Move data from Row to Column

When there is a huge data in a single column; we may need to migrate some data to next column using page break. VBA code for this utility:

Option Explicit
Dim sht As Worksheet, myrng As Range, myrng1 As Range, count As Integer, i As Long
Dim myrng2 As Range, rowcount As Long
Sub moveRowtoColumn()
On Error Resume Next
Set sht = ThisWorkbook.Sheets(1)
Set myrng = sht.UsedRange.Columns(1)
count = sht.HPageBreaks.count
i = 0

For i = 1 To count
 
    Set myrng1 = sht.HPageBreaks(i).Location
    Set myrng2 = sht.HPageBreaks(i + 1).Location.Offset(-1, 0)
        If myrng2 Is Nothing Then
            Range(myrng1, myrng.Cells(65500, 1).End(xlUp)).Copy Destination:=sht.Cells(1, i + 1)
        Else
            Range(myrng1, myrng2).Copy Destination:=sht.Cells(1, i + 1)
        End If
     
    Set myrng1 = Nothing
    Set myrng2 = Nothing
Next

sht.Range(sht.HPageBreaks(1).Location.Address, myrng.Cells(65500, 1).End(xlUp).Address).Delete
    Set myrng = Nothing
End Sub

Excel VBA LogTracker

VBA code for generating Excel Log tracker

In module:

Sub eLoggerInfo(Evnt As String)
Application.ScreenUpdating = False
Dim counter As Long
    cSheet = ActiveSheet.Name
        If sheetExists("LoggerInfo") = False Then
            Sheets.Add.Name = "LoggerInfo"
            Sheets("LoggerInfo").Select
            'ActiveSheet.Protect "Pswd", userinterfaceonly:=True
        End If
        Sheets("LoggerInfo").Visible = True
        Sheets("LoggerInfo").Select
        'ActiveSheet.Protect "Pswd", userinterfaceonly:=True
' assigning value to counter
        counter = Range("A1")
       
        If counter <= 2 Then
            counter = 3
            Range("A2").Value = "Event"
            Range("B2").Value = "User Name"
            Range("C2").Value = "Domain"
            Range("D2").Value = "Computer"
            Range("E2").Value = "Date and Time"
        End If
        'fixing event length to 25
        If Len(Evnt) < 25 Then Evnt = Application.Rept(" ", 25 - Len(Evnt)) & Evnt
   
            Range("A" & counter).Value = Evnt
            Range("B" & counter).Value = Environ("UserName")
            Range("C" & counter).Value = Environ("USERDOMAIN")
            Range("D" & counter).Value = Environ("COMPUTERNAME")
            Range("E" & counter).Value = Now()
            counter = counter + 1
          'Deleting  records if no. of records are more than 20000
            If counter > 20002 Then
                Range("A3:A5002").Select
                dRows = Selection.Rows.Count
                Selection.EntireRow.Delete
                counter = counter - dRows
            End If
            Range("A1") = counter
            Columns.AutoFit
            Sheets(cSheet).Select
            Sheets("LoggerInfo").Visible = xlVeryHidden
            Application.ScreenUpdating = True
       
End Sub

Function sheetExists(sheetName As String) As Boolean
On Error GoTo SheetDoesnotExit
    If Len(Sheets(sheetName).Name) > 0 Then
        sheetExists = True
        Exit Function
    End If
SheetDoesnotExit:
        sheetExists = False
End Function
Sub ViewLoggerInfo()
    Sheets("LoggerInfo").Visible = True
    Sheets("LoggerInfo").Select
End Sub
Sub HideLoggerInfo()
    Sheets("LoggerInfo").Visible = xlVeryHidden
End Sub

In Thisworkbook module:

Private Sub workbook_beforeprint(cancel As Boolean)
Dim Evnt As String
Evnt = "Print"
Call eLoggerInfo(Evnt)
End Sub


Private Sub workbook_beforesave(ByVal saveasUI As Boolean, cancel As Boolean)
    Dim Evnt As String
    Evnt = "Save"
    Call eLoggerInfo(Evnt)

End Sub

Private Sub workbook_Open()
    Dim Evnt As String
    Evnt = "Open"
    Call eLoggerInfo(Evnt)

End Sub

Floating Button in VBA

VBA code for creating floating button in excel sheet:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (Target.Column < 2 And Target.Row < 2) Then Exit Sub
With ActiveSheet.Shapes("CommandButton1")
    .Top = Target.Offset(, 0).Top
    .Left = Target.Offset(, 0).Left
End With
End Sub

Build-up your Logic in VBA(Create Pyramid)

Sub test()
k = 1
c = 9
For i = 10 To 1 Step -1
For j = c To k Step -1

    Cells(i, j) = "*"
     
Next j
k = k + 1
c = c - 1
Next i

End Sub

Calculation of Net Working Days

Here is a small VBA code for calculating net working days excluding Sunday:




Option Explicit


'Date should of "dd-mmm" format in cells

Function clcnetworkingdays(startdate As Date, enddate As Date) As Variant
Dim daystaken As Integer
Dim cnt As Integer, tempCounter As Integer
daystaken = enddate - startdate

    For cnt = 1 To daystaken
        If WorksheetFunction.Text((startdate + cnt), "ddd") = "Sun" Then
            tempCounter = tempCounter + 1
         
         End If
 
    Next
    daystaken = daystaken - tempCounter
    clcnetworkingdays = daystaken
End Function