Get URL from an hyperlink in Excel

VBA code to get the URL address from a link:

'Extract URL from hyperlink
Function HLink(rng As Range) As String
  If rng(1).Hyperlinks.Count Then HLink = rng.Hyperlinks(1).Address
End Function

Send emails through Outlook using Excel

Here is the VBA code to send emails from Outlook:

Sub SendEmails()
Dim OlApp As Object
Dim OlMail As Object

Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.CreateItem(olMailItem)

With OlMail
    .Display
    .To = "aaa@gmail.com"
    .CC = "bbb@gmail.com"
    .Subject = "Test Email"
    .Attachments.Add "C:\Test.xlsx"
    .Body = "Test email"
    .Save
    .Close olPromtForSave
    .Send
End With

End Sub

Pasting data in the reverse order

You might have come across with situation where you wanted to paste your data in reverse order. In the example below we want the numbers in Data column in reverse order. This can be done using excel formula.

Data	Reverse Data
1	5
2	4
3	3
4	2
5	1

Following formula can be used:

=INDEX($A$2:$A$6,ROWS(A2:A$6))

Copy data from Excel to Notepad

VBA Code to copy data from Excel to Notepad:


Sub copyPastedata_in_Notepad()
With Application
Selection.Copy
Shell "notepad.exe", 3
SendKeys "^v"
VBA.AppActivate .Caption
.CutCopyMode = False
End With

End Sub

VBA Code to Collapse and Expand columns

VBA Code to Collapse and Expand columns based on the given criteria:


Sub Collapse_Expand()
Dim w As Worksheet
Dim pt As PivotTable
Dim FinYear As String
Dim QTD As String

FinYear = "FY" & Right(Date, 2)
QTD = "Q3                             "
        
        For Each w In ThisWorkbook.Worksheets
            If ActiveSheet.Name = "Sheet1" Or ActiveSheet.Name = "Sheet2" Then
                ActiveSheet.PivotTables("PivotTable1").PivotFields("Rev_Cost").ShowDetail = False
                ActiveSheet.PivotTables("PivotTable1").PivotFields("Quarter").ShowDetail = False
                ActiveSheet.PivotTables("PivotTable1").PivotFields("Year").ShowDetail = False
                
                ActiveSheet.PivotTables("PivotTable1").PivotFields("Rev_Cost").PivotItems("Rev").ShowDetail = True
                ActiveSheet.PivotTables("PivotTable1").PivotFields("Rev_Cost").PivotItems("Cost").ShowDetail = True
                ActiveSheet.PivotTables("PivotTable1").PivotFields("Year").PivotItems(FinYear).ShowDetail = True
                ActiveSheet.PivotTables("PivotTable1").PivotFields("Quarter").PivotItems(QTD).ShowDetail = True
            End If
                On Error Resume Next
                Sheets(ActiveSheet.Index + 1).Activate
                If Err.Number <> 0 Then Sheets(1).Activate
        Next
End Sub

Zip Files using VBA

VBA Code to zip files:

Private Sub ZipFile_FX(ZipFileName As String, fileToBeZipped As String)
Const ZIPEXELOCATION = "c:\program files\winzip\winzip32.exe"
Shell ZIPEXELOCATION & " -a " & Chr(34) & ZipFileName & Chr(34) & _
" " & Chr(34) & fileToBeZipped & Chr(34), vbNormalFocus
End Sub

sub zips()
Call ZipFile_FX("c:\b.zip", "c:\b.xls")
end sub

Zip files in a folder

VBA code to zip files in any folder:


Sub Zip_File_Or_Files()
    Dim FSO As New FileSystemObject
    Dim Fld As Folder, Fle As File
    Dim strDate As String, DefPath As String
    Dim oApp As Object
    Dim FileNameZip

    Sheets("Sheet1").Select
    LR = Range("B2").End(xlDown).Row
    For LV = 3 To LR
        DefPath = Range("B3").Value
        FileNameZip = DefPath & "\TestFile" & ".zip"
        NewZip (FileNameZip)
        Set Fld = FSO.GetFolder(DefPath)
        For Each Fle In Fld.Files
            If InStr(1, Fle.Type, "Excel") <> 0 Then
                Set oApp = CreateObject("Shell.Application")
                oApp.Namespace(FileNameZip).CopyHere Fle.Path
                 'Keep script waiting until Compressing is done
                On Error Resume Next
                Application.Wait (Now + TimeValue("0:00:01"))
                On Error GoTo 0
            End If
        Next Fle
    Next LV
End Sub

Sub NewZip(sPath) 'Create empty Zip File
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub