VBA Files Exists in the Selected Folder

!...VBA program to Display All the files in the Selected folder with name,filepath,size of file etc...!

Sub File_Names_infolder()
Dim fso As Scripting.FileSystemObject
Dim fld, fil As Object
Dim i As Integer
i = 1
Set fso = CreateObject("scripting.filesystemobject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Analyfolder"
.Show
End With
Set fld = fso.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each fil In fld.Files
Cells(i, 1).Value = fil.Path
Cells(i, 2).Value = fil.Name
Cells(i, 3).Value = Left(fil.Name, Application.WorksheetFunction.Find(".", fil.Name) - 1)
Cells(i, 4).Value = Round(fil.Size / 1024)
i = i + 1
Next fil
End Sub

Important Functions in VBA

!...Some Important Functions in Excel-VBA....!

Debug.Print StrReverse("abcdefghijklmnopqrstuvwxyz") '''' Reverse a String
Debug.Print UCase("amit verma") '' Print String in Upper Case
Debug.Print LCase("AMIT VERMA") '' Print String in Upper Case
Debug.Print Replace("amit verma", " ", "") '' Replace Space with null Values
Debug.Print IsNumeric(12305) ''' Function True if given value is numerice either false
Debug.Print MonthName(10) '' Print the Monthname of the given value
Debug.Print Format(Now, "dd-mmm-yyyy") '' Function display only Date in the given format
Debug.Print Format(Now, "hh:mm:ss") '' Function display only Time in the given format
Debug.Print Asc("a") '' Displays Ascii Value of the give character
Debug.Print Chr(85) '' Displays character from the basis of given number
Debug.Print CDate("12 feb 2013") '' Converts a String into Date
Debug.Print IsObject(Object) '' print true if the given values is object either false
Debug.Print IsEmpty(abc) ''print true if the given values is empty either false
Debug.Print IsError("#N/A") ''print true if the given values is error either false
Debug.Print InputBox("Enter Any Value") '' To Take user's Input
x = MsgBox("Do U Want to Run Again", vbYesNoCancel) '' Message Box & Properties
Debug.Print x
Debug.Print LTrim("     akshay") '' Remove spaces from the left
Debug.Print RTrim("akshay     ") '' Remove spaces from the left
Debug.Print Trim("    akshay     ") '' Remove leading & trailing spaces from the left
Shell "notepad" '' To open installed applications on your system
MkDir "E:\abc" '' Creates directory in E: drive with the name ABC
RmDir "E:\abc" '' Removes directory in E: drive with the name ABC
Kill "e:\*.xls" '' Delete All the file in the E: directory with ".xls" extension
FileCopy "E:\abc\xyz.xls", "E:\" '' Copy "xyz.xls" file to E: drive
Name "D:\VIKAS DATA\VBA PROGRAMMING\excel macros\testing.xls" As "D:\VIKAS DATA\VBA PROGRAMMING\testing.xls" '' Move/Rename file
Range("a1:z20").Select '' Function Selects the cells A1:Z20 in the activesheet
Workbooks.Open "E:\abc.xls" '' To Open another Excel File
Cells(1, 1).Select '' Selects 1st cell and 1st column in the activesheet
Sheets("abc").Select ''' Selects the sheet whose name "abc"
Worksheets("abc").Select ''' Selects the sheet whose name "abc"
ActiveWorkbook.Sheets("abc").Select ''' Selects the sheet whose name "abc"
ActiveWorkbook.Worksheets("abc").Select ''' Selects the sheet whose name "abc"
result = Application.WorksheetFunction.CountIf(Range("a:a"), ">10") '' Use Excel worksheetfunction like this in VBA
Cells.ClearContents '' This Will Clear All the Contents in Current Sheet
Sheets.Add.Name = "New Workbook" '' Add new sheet with the Name="New Workbook"

VBA to Change Sheet Tab Color

!.... VBA program to Change the Sheets Tab Color.....!

Sub Change_Sheettab_Color()

For i = 1 To 56

Sheets.Add.Name = i

Sheets(i).Tab.ColorIndex = i

ActiveSheet.Next.Select

Next

End Sub

Excel VBA Programming in VBScript

'''' Note copy the Whole Script and paste into notepad and save the notepad file with "filename.vbs" extension and click the saved notepad file to run Vbscript

Dim xl, y
set xl=createobject("Excel.application")
xl.visible=1
xl.workbooks.add
call add_sheets

Sub add_sheets()
Dim sname
If MsgBox("Do you Want to Add More Sheets", vbYesNo) = vbYes Then
sname = InputBox("Enter the Name for New Sheet")
xl.Sheets.Add.Name = sname
Else
Exit Sub
End If
Call add_sheets
End Sub

VBA Autorun Macros

!... VBA program to schedule your Macro at specific time frame.......!

Sub Autorun_Macro()
Application.OnTime Now + TimeValue("00:00:10"), "Unhide_AllSheets" '''' Macro Automatically Runs when Current time exceeds 10 Seconds
Application.OnTime TimeValue("16:45:20"), "Unhide_AllSheets" '''' Macro Automatically Runs when the Given Time Reached
End Sub

VBA to Unhide/Show All Sheets

!....VBA program to Unhide all Sheets in the Active Workbook....!

Sub Unhide_AllSheets()
Dim wb As Worksheet
For Each wb In Worksheets
wb.Visible = 1
Next wb
End Sub

Sub AllSheets_Unhide()
For i = 1 To Worksheets.Count
Sheets(i).Visible = 1
Next
End Sub

Sub Show_AllSheets()
Dim i
i = 1
While i <= Sheets.Count
Worksheets(i).Visible = True
i = i + 1
Wend
End Sub

VBA Data Sort Using Cell Background Color

!....VBA Program to Sort Data by Cell Background Color....!

Sub Sort_by_FontColor()
Application.ScreenUpdating = 0
Columns("b").Insert
For i = 2 To Range("a65536").End(xlUp).Row
Cells(1, 2) = "Color Index"
Cells(i, 2) = Cells(i, 1).Font.ColorIndex
Next
Range("a2:" & Chr(64 + Cells(1, 1).End(xlToRight).Column) & Range("A1").End(xlDown).Row).Sort Range("b2"), xlAscending
Columns("b").Delete
End Sub

VBA Data Sort Using Font Color

!.....VBA Program to Sort Data by Font Color.....!

Sub Sort_by_FontColor()
Application.ScreenUpdating = 0
Columns("b").Insert
For i = 2 To Range("a65536").End(xlUp).Row
Cells(1, 2) = "Color Index"
Cells(i, 2) = Cells(i, 1).Font.ColorIndex
Next
Range("a2:" & Chr(64 + Cells(1, 1).End(xlToRight).Column) & Range("A1").End(xlDown).Row).Sort Range("b2"), xlAscending
Columns("b").Delete
End Sub

Copy All Sheets Data Into One Sheet (VBA Program)

!....VBA Program to Copy All the Data in the Activeworkbook & Paste into One Sheet....!

Sub Copy_Allsheets_Data()

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Consolidate Sheet"
For i = 1 To Sheets.Count - 1
Sheets(i).Select
Range("a1", Range("a1").SpecialCells(xlCellTypeLastCell)).Copy
If Sheets("Consolidate Sheet").Range("a1") = "" Then
Sheets("Consolidate Sheet").Range("a1").PasteSpecial xlPasteValues
Else
Sheets("Consolidate Sheet").Select
Cells(Range("a1048576").End(xlUp).Row + 2, 1).PasteSpecial xlPasteValues
End If
Next

End Sub

Excel-VBA to Export Excel Data into PDF File

!.....VBA program to Export (Activeworkbook & Activesheet) data into PDF File....!

Sub Export_to_PDF()
ActiveSheet.ExportAsFixedFormat xlTypePDF, "d:\abc1.pdf"
ActiveWorkbook.ExportAsFixedFormat xlTypePDF, "d:\abc2.pdf"
End Sub

User Defined function to Reverse a String

!....VBA program to Reverse a String.....!

Function String_Reverse(x) As String
String_Reverse = StrReverse(x)
End Function

Function Reverse_String(x) As Variant

Dim a, b As Variant
b = ""
While Len(x) > 0
a = Right(x, 1)
x = Left(x, Len(x) - Len(a))
b = b & a
Wend
Reverse_String = Replace(b, " ", "")

End Function

VBA program to ADD sheets with the Month Names

!.....Program to Add sheets in the Activeworkbook with all the Month Names.......!

Sub Add_Sheets()

On Error Resume Next
Application.DisplayAlerts = 0
For i = 1 To 12
On Error Resume Next
Sheets(MonthName(i)).Delete
Sheets.Add.Name = MonthName(i)
ActiveSheet.Next.Select
Next
Sheets(Array("sheet1", "sheet2", "sheet3")).Delete
Application.DisplayAlerts = 1

End Sub

Add Blank Rows After Each Row in the Active Sheet

!....Excel VBA program to Add Blank Rows after Each Row in the Activesheet...!

Sub add_blankrow()

Application.ScreenUpdating = False
For i = 1 To Range("a1").End(xlDown).Row
ActiveCell.Offset(1, 0).Select
Rows(ActiveCell.Row).Insert
ActiveCell.Offset(1, 0).Select
Next

End Sub

Excel VBA program to Clean Trim Values within you selection

!....Excel VBA program to clean trim values according to your selection...!

Sub Remove_Space()

Dim rw As Integer
Dim cl As Integer
Dim c, r As Integer

c = ActiveCell.Column
If ActiveCell = "" Then
MsgBox "Blank or No Cell is Selected"
Exit Sub
End If
For i = 1 To Selection.Columns.Count
r = ActiveCell.Row
For j = 1 To Selection.Rows.Count
Cells(r, c) = Trim(Cells(r, c))
r = r + 1
Next j
c = c + 1
Next i

End Sub

Sample file for the above VBA Program:----------------------------

Download Macro File

Copy All the Charts in the Excel file & Paste into Word

Excel VBA Program to Copy All the charts present in the Activesheet & paste into word file and then Print the word file.......

Sub Copy_charts_into_word()

Dim doc As New Word.Application ''' tools->reference->microsoft word 12.0 object library
doc.Documents.Add
doc.Visible = 1
For i = 1 To ActiveSheet.ChartObjects.Count
Sheet1.ChartObjects(i).Copy
Word.Selection.Range.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=wdInLine
Word.FindKey(KeyCode:=BuildKeyCode(wdKeyEnd)).Execute
Word.Selection.TypeParagraph
Word.Selection.TypeParagraph
Next
Word.ActiveDocument.PrintOut
Word.ActiveDocument.Save
doc.Quit
Set doc = Nothing

End Sub


Sample file for the above VBA Program:----------------------------

Download Macro File

User Defined Function in Excel to Extract Alphabets

!...Below Code to Create User Defined Function in Excel....!

Use:- To extract Alphabets

Function EXTRACT_ALPHA(str) As Variant

Dim i As Integer
Dim char, alpa As Variant
char = ""
For i = 1 To Len(WorksheetFunction.Trim(str))
alpha = Mid(str, i, 1)
If IsNumeric(alpha) = True Or Asc(UCase(alpha)) > 0 And Asc(UCase(alpha)) < 65 Or Asc(UCase(alpha)) > 90 Or (alpha) = " " Then
Else
char = char & alpha
End If
Next
EXTRACT_ALPHA = char

End Function



_____________________________________
Example:-
=EXTRACT_ALPHA ("^&&5**111CDFG8899B$$$$$_~%^*")

Result--------------------------------->CDFGB

User Defined Function in Excel to Extract Special Characters

!.....Below Code to Create User Defined Functions in Excel....!

Use:- To extract special characters

Function EXTRACT_SPECIAL_CHAR(str) As Variant Dim i As Integer

Dim spl, splchar As Variant
spl = ""
For i = 1 To Len(str)
splchar = Mid(str, i, 1)
If IsNumeric(splchar) = True Or Asc(UCase(splchar)) > 64 And Asc(UCase(splchar)) < 91 Or splchar = " " Then
Else
spl = spl & Mid(str, i, 1)
End If
Next
EXTRACT_SPECIAL_CHAR = spl

End Function

_________________________________________
Example:-
=EXTRACT_SPECIAL_CHAR("^&&5**111CDFG8899B$$$$$_~%^*")



Result------------->  ^&&**$$$$$_~%^*

User Defined Function in Excel to extract numbers & then sum of the values

!.......Below Code to Create User Defined Functions in Excel........!

Use:- To extract numbers & then sum of the values.....

Function EXTRACT_NUMBERS_and_Sum(x) As Variant

Dim c As Variant
c = 0
For i = 1 To Len(Replace(x, " ", ""))
If IsNumeric(Mid(x, i, 1)) = True Then
c = c + Mid(x, i, 1)
End If
Next
EXTRACT_NUMBERS_and_Sum = c

End Function

______________________________________________

Example:-
= EXTRACT_NUMBERS_and_Sum("^&&5**111CDFG8899B$$$$$_~%^*")
Result-------------->  42

User defined function in excel to Change case char by char

!................Use:- Change Case Char by Char............!

Function CHANGE_CASE(x) As Variant

Dim y As Variant
y = ""
For i = 1 To Len(x)
If Asc(Mid(x, i, 1)) > 64 And Asc(Mid(x, i, 1)) < 91 Then
y = y & LCase(Mid(x, i, 1))
Else
y = y & UCase(Mid(x, i, 1))
End If
Next
CHANGE_CASE = y

End Function



_______________________________________________
Example:-
=CHANGE_CASE ("AbcDeFgHiJkLmNoPqRsTuVwXyZ")

Result----------------------------------->aBCdEfGhIjKlMnOpQrStUvWxYz

User defined function in excel to extract numbers

!..........Use:- To extract numbers--------!

Function EXTRACT_NUMBERS(x) As Variant

Dim c As Variant
c = ""
For i = 1 To Len(Replace(x, " ", ""))
If IsNumeric(Mid(x, i, 1)) = True Then
c = c & Mid(x, i, 1)
End If
Next
EXTRACT_NUMBERS = c

End Function

_________________________________________
Example:-
 =EXTRACT_NUMBERS ("^&&5**111CDFG8899B$$$$$_~%^*")
Result----------------------->51118899

User defined function in excel to sent an email from Outlook

Function Email_Send (too As Variant, Optional ccc As String, Optional attach As String, Optional subj As String)

Dim otl As New Outlook.Application  ''''''Tools->Reference-Microsoft Outlook 12.0 Object Library'''''
Dim ml As MailItem
Set ml = otl.CreateItem(olMailItem)
If Len(too) = 0 Then
Email_Send = "Not Sent -> Blank Email Id"
Exit Function
End If
For i = 1 To Len(too)
If Mid(too, i, 1) = "@" And Right(too, 4) = ".com" Or Right(too, 4) = ".net" Then
Exit For
End If
Next
If i > Len(too) Then
Email_Send = "Not Sent -> Invalid Email"
Else
With ml
           ml.To = too
           If Len(ccc) > 0 Then
           ml.CC = ccc
           End If
           If Len(attach) > 0 Then
           ml.Attachments.Add attach
           End If
           If Len(subj) > 0 Then
           ml.Subject = subj
           End If
           ml.Display
End With
Email_Send = "Email Sent"
End If

End Function

Shortcut Keys in Excel

!.......Pls find below shortcut keys in Excel......!

Delete Sheet:- Alt+E+L
Move Sheet:- Alt+E+M



Insert Pivot Table:- Alt+D+P
Sheet Rename:- Alt+O+H+R
Create List:- Alt+D+L
Advanced Sort:- Alt+D+S
AutoFit to text :- Alt+O+C+A
Insert New Sheet :- Shift+F11
Insert Comment:- Shift+F2
Format Cell options:- Ctrl+1 & Alt+O+E
Fill down Text:- Ctrl+D
Bold Text:- Ctrl+B & Ctrl+2
Italic Text:- Ctrl+I & Ctrl+3
Underline Text:- Ctrl+U & Ctrl+4
Insert Strike into Text:- Ctrl+5
Hide Active or Selected Row:- Ctrl+9
Hide Active or Selected Row:- Ctrl+0
Insert Function Option:- Shift+F3
Print Preview:- Ctrl+F2
Toggle b/w Excel & VBA Editor:- Alt+F11
Show Macros in Current Workbook:- Alt+F8
Create Hyperlink Text:- Ctrl+K
Insert New Row or Columns:- Ctr+
Delete New Row or Columns:- Ctr-
Insert Chart:- F11
Save As Workbook:- F12
Select 1st Cell in Worksheet:- Ctrl+Home Key
Toggle b/w two or more workbooks:- Ctrl+Tab
Toggle b/w sheets:- Ctrl+PgUp key move next sheet & Ctrl+PgDn key move previous sheet
Show all Formulas in workbook:- Ctrl+~
Insert or Remove Filter:- Ctrl+Shift+L & Alt+D+F+F
Active Paste Special Menu:- Alt+E+S
Display Text to Column Menu:- Alt+D+E
Increase or Decrease formula bar height:- Ctrl+Shift+U
Show Go To :- F5 & Ctrl+G
Show Find & Replace:- Ctrl+H
Create Table:- Ctrl+L
Show Custom Color Menu:- Alt+O+H+T
Show Font Menu:- Ctrl+Shift+P & Ctrl+Shift+F

Copy Excel Data into Word File Using Excel-VBA

!...........Excel VBA Program to Copy Activesheet data and paste into Ms-Word Table...........!

Sub copy_to_Word()

Dim doc As New Word.Application   '' Tools->Reference->Microsoft Word 12.0 Object Library
Dim i, j As Integer
doc.Documents.Add
doc.ActiveDocument.Tables.Add Word.Selection.Range, ActiveSheet.Range("a1").End(xlDown).Row, ActiveSheet.Range("a1").End(xlToRight).Column
doc.ActiveDocument.Tables(1).Style = "table Grid"
doc.Visible = 1
For i = 1 To Range("a1").End(xlToRight).Column

For j = 1 To Range("a1").End(xlDown).Row
doc.ActiveDocument.Tables(1).Columns(i).Cells(j).Range = Cells(j, i).Value

Next j
Next i
doc.ActiveDocument.Save
ActiveWorkbook.Close savechanges = 1

End Sub

Sample file for the above VBA Program:----------------------------
Download Macro File

Excel-VBA program to copy MS-Access table data into Activesheet

Excel-VBA program to copy MS-Access table data and paste into Activesheet............!

Note:- After running the Macro Code, Type your SQL query to filter your data and paste into activesheet............!



Sub copy_Access_data()

Dim rs As DAO.Recordset        ''''' Tools--> Reference--> Microsoft DAO 3.6 object library
Dim xs As New Access.Application     '''' Tools--> Reference--> Microsoft Access 12.0 object library
Dim i, j As Integer
Dim query As Variant

MsgBox "Open MS-Access Database"
xs.OpenCurrentDatabase (Application.GetOpenFilename)
xs.Visible = 1

query = InputBox("Enter Your SQL Query")
Set rs = CurrentDb.OpenRecordset(query)
Cells(1, 1).Value = "S.No"
For i = 1 To rs.Fields.Count
j = 1
Cells(1, i + 1).Select
ActiveCell.Value = rs.Fields(i - 1).Name

While Not rs.EOF
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = rs.Fields(i - 1)
Cells(ActiveCell.Row, 1) = j
rs.MoveNext
j = j + 1
Wend

rs.MoveFirst
Next
xs.Quit
Set xs = Nothing
ActiveWorkbook.Close savechanges = 1

End Sub


Sample file for the above VBA Program:----------------------------
Download Macro File

Excel-VBA program to copy all word tables and paste into excel

Excel VBA Program to copy all the tables present in word file and paste it into Activesheet.

Sub copy_wordtables()

Dim doc As New Word.Application    ''''''  Tools --> reference -->Microsoft word 12.0 object library''
Dim data As Variant

MsgBox "Open Any Word File Which Contains Table", vbOKOnly, "OPEN WORD FILE"
doc.Documents.Open Application.GetOpenFilename
doc.Visible = 1

For i = 1 To doc.ActiveDocument.Tables.Count

For j = 1 To doc.ActiveDocument.Tables(i).Columns.Count

For k = 1 To doc.ActiveDocument.Tables(i).Columns(j).Cells.Count
data = doc.ActiveDocument.Tables(i).Columns(j).Cells(k).Range.Text
Cells(k, j) = Left(data, Len(data) - 2)
Next k
Next j
Next i

doc.Quit
Set doc = Nothing
ActiveWorkbook.Close savechanges = 1
End Sub


Sample file for the above VBA Program:----------------------------

Download Macro File