VBA Method for Age Calculation :

Function DOB(rng As Range)
DOB = VBA.Format(VBA.DateDiff("d", rng, Date), "yy mm dd")
End Function

Text to column

Hi,
if you are finding a code such like Text to Column . it can help you


    Sub TextToColumn()
        Dim ArrList
        Dim rngCell As Range
        Dim strDelimeter    As String
        strDelimeter = Application.InputBox("Please Provide a Delimeter", "Text To Column")
        For Each rngCell In Selection
            ArrList = Split(rngCell.Value, strDelimeter)
            If WorksheetFunction.CountA(rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1)) > 1 Then
                If MsgBox("Some data can be replaced ,Do you want to Continue", vbYesNo) = vbYes Then
                    rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1).Value = ArrList
                End If
                Else
                rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1).Value = (ArrList)
                rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1).Value = rngCell.Offset(, 1).Resize(1, UBound(ArrList) + 1).Value
            End If
        Next
    End Sub

Hope you will post an excellent solution here

welcome  my followers to this quiz , you need to write a function to get the file extension through either a VBA function or inbuilt excel function

FIleName	.
Book1.Doc
Book.book1.xls
book.book1.book1.xlsx
book.book.book.book1.xlsm

Hope you will post a excellent function :)

Age Calculation :

If Current Date in A1 and Date of Birth in B2 then Put this Function to Calculate Age:

=DATEDIF(B2,B1,"Y")&" Year "&DATEDIF(B2,B1,"YM")&" Month "&DATEDIF(B2,B1,"MD")&" Days"

Unique List by Function

See the attached File :

http://www.sendspace.com/file/ld5mqw

Get Last Populated Cell Address

Paste it on worksheet Change the Range Address and Press Shift+Ctrl+Enter

=IFERROR(ADDRESS(MAX(IF(LEN(A1:I36)>0,ROW(A1:I36)),0),MAX(IF(LEN(INDIRECT(MAX(IF(LEN(A1:I36)>0,ROW(A1:I36)),0)&":"&MAX(IF(LEN(A1:I36)>0,ROW(A1:I36)),0)))>0,COLUMN(INDIRECT(MAX(IF(LEN(A1:I36)>0,ROW(A1:I36)),0)&":"&MAX(IF(LEN(A1:I36),ROW(A1:I36)),0)))))),0)

Hide and Show

Sub HideAll()
    With Application
        .DisplayFormulaBar = False
        .DisplayScrollBars = False
        .DisplayStatusBar = False
    End With
    With ActiveWindow
        .DisplayGridlines = False
        .DisplayHeadings = False
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
        .DisplayWorkbookTabs = False
    End With
End Sub

Sub ShowALl()
    With Application
        .DisplayFormulaBar = True
        .DisplayScrollBars = True
        .DisplayStatusBar = True
    End With
    With ActiveWindow
        .DisplayGridlines = True
        .DisplayHeadings = True
        .DisplayHorizontalScrollBar = True
        .DisplayVerticalScrollBar = True
        .DisplayWorkbookTabs = True
    End With
End Sub

Assigning Value

It's a best way to Assign Multiple values to Range By Array


Sub AssignValues()
Range("A1:D1").Value = Array("Sr.No", "Name", "Contact", "Address")
End Sub

Delete Multiple worksheets

You can use this code to delete multiple sheet without loop

Sub DeleteSheet()

Application.DisplayAlerts = False

    Worksheets(Array("Sheet1", "Sheet1", "Sheet1")).Delete

Application.DisplayAlerts = True

End Sub

JOIN

its a method to concatenation values in a string variable , you can use this trick to avoid a Loop for this purpose.

Sub MakeString()

    Dim strSting As String

    strSting = Join(Application.Transpose(Selection), ",")

    Debug.Print strSting

End Sub

Evaluate :

EVALUATE  is method in VBA which can evaluate any Function of Excel in VBA and can return the value in a variable.

To make your code faster you can use this EVALUATE trick in VBA to avoide extra looping .. it can work  till 255 cells


Like if you want to Change Case of some Text on selection you can use this command in vba.

selection=evaluate("=if(len(" & selection.address &")>0,upper(" & selection.address &")," & selection.address &")")


if you want any Calculation with cells :

selection= Evaluate( selection.address &"/1000")

Compiling Workbooks :

Please Visit this page.
http://www.excelfox.com/forum/f20/compiling-workbook-data-240/#post808

Align Shapes on Worksheets :

Many Time we have Lot of Shapes On a Worksheets and we have to Align All those Shapes . This is a Code snippet to Make this Task easy.

Sub MakeMyShapes()
Dim intICounter         As Integer
Dim shpShape            As Shape
Dim sngHeight           As Single
Dim sngWidth            As Single
Dim IntNShapes          As Integer
Dim intleft             As Integer
Dim intTop              As Integer
Dim bytRow              As Byte
Dim intMaxH             As Integer
Dim intMaxW             As Integer
Dim intTempArr()        As Integer
bytRow = Application.InputBox("Please enter Number of Rows (0-255)")
    With ActiveSheet
        IntNShapes = .Shapes.Count
        intleft = .Shapes(1).Left
        intTop = .Shapes(1).Top
        sngHeight = .Shapes(1).Height
        sngWidth = .Shapes(1).Width
       
        ReDim intTempArr(IntNShapes)
            For intICounter = 0 To IntNShapes - 1
                intTempArr(intICounter) = .Shapes(intICounter + 1).Height
            Next
            intMaxH = WorksheetFunction.Max(intTempArr)
       
            For intICounter = 0 To IntNShapes - 1
                intTempArr(intICounter) = .Shapes(intICounter).Width
            Next
            intMaxW = WorksheetFunction.Max(intTempArr)
       
        For intICounter = 1 To IntNShapes
            .Shapes(intICounter).Left = intleft
            .Shapes(intICounter).Top = intTop
            If intICounter Mod bytRow = 0 Then
                intleft = .Shapes(intICounter + 1 - bytRow).Left + sngWidth
                intTop = .Shapes(1).Top
            Else
                intleft = .Shapes(intICounter).Left
                intTop = .Shapes(intICounter).Top + sngHeight
            End If
                .Shapes(intICounter).TextFrame.Characters.Text = intICounter
            Next
    End With
End Sub

Excel Fox

Excel


Check out this Excellent Sites for Office Automation Code Snippets :

http://www.excelfox.com/forum/forum.php

Transpose Data :

If you have data in Excel Sheet like :
Application.screenUpdating=false
Sub CreateList()
    Dim rngRange    As Range
    Dim rngCell     As Range
    Dim rngCell2    As Range
    Dim bytCol      As Byte
    Set rngRange = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    rngRange.Copy Range("C1")
    Range("A:B").Sort key1:=Range("A1")
    Range("C:C").RemoveDuplicates 1
    bytCol = 1
        For Each rngCell In Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row)
                For Each rngCell2 In rngRange
                       If rngCell2.Value = rngCell.Value Then
                            rngCell.Offset(0, bytCol).Value = rngCell2.Offset(0, 1).Value
                            bytCol = bytCol + 1
                       End If
                Next rngCell2
                bytCol = 1
        Next rngCell
Application.screenUpdating=True           
End Sub

You can transpose this Data in this Way By using Mention Code:

Sorted List By Array Function :

If you want to Sort Your List By Function , You can use this Array Function ,



Option Base 1
Option Compare Text
Function SortedList(rng As Range) As Variant
        Dim arr() As Variant
        Dim rw, cl As Double
        r = rng.Rows.Count
        cl = 1
        ReDim arr(r, cl)
                arr = rng
                For i = 1 To r
                    For j = 1 To r - i
                        If arr(j, 1) > arr(j + 1, 1) Then
                            temp = arr(j, 1)
                                arr(j, 1) = arr(j + 1, 1)
                                arr(j + 1, 1) = temp
                            End If
                    Next
                Next
            SortedList = arr
End Function

Check if the Table is Exist or Not In Access DataBase

If you want to Check the particular table is exist in Access Database or Not  You Can use this Function :



Option Compare Text
Sub IsExist()
Dim cn As ADODB.Connection
    Dim rst As Recordset
    Dim MyConn As String
    MyConn = "D:\MyDataBase.accdb"
    Set cn = New ADODB.Connection


    With cn
    .Provider = "Microsoft.ace.Oledb.12.0"
    .Open MyConn
    End With
            
        Set rst = cn.OpenSchema(adSchemaTables)
        rst.MoveFirst
        Do Until rst.EOF
                If rst!Table_Name = "MyTable1" Then
                MsgBox "Table Exist "
                Exit Do
                End If
                rst.MoveNext
        Loop
        
        rst.Close
        cn.Close
End Sub

Making Different Workbook WithOut Formulas :

If you have a workbook which contain Lot of Function and you want to copy all that values in another Workbook You can use this Code :



Sub GetALlSheet()
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = ActiveWorkbook
        Application.Workbooks.Add
        For Each sh In wb.Sheets
            sh.Copy ActiveWorkbook.Sheets(1)
                ActiveSheet.Cells.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                Application.CutCopyMode = False
        Next
        ActiveWorkbook.SaveAs "D:\MyWorkbook"
        ActiveWorkbook.Close
End Sub

Get All Worksheets Name by Array Function :

If You want to Get all Existing worksheet in a Workbook you can use this Array Function :
Suppose you have 100 Worksheet in a Workbook and You want all sheet name in a sheet then select any 100 cells Type this Function name and press Shift+Ctrl+Enter , You will get all sheet Names :


Function Sheetname() As Variant
Application.Volatile
Dim Sheet() As Variant
Dim r As Integer
Dim c As Integer
Dim i As Integer

With Application.Caller
        r = .Rows.Count
        c = .Columns.Count
End With

ReDim Sheet(1 To r, 1 To c)
    i = 1
    For j = 1 To r
        For k = 1 To c
        If i > Sheets.Count Then Exit For
        Sheet(j, k) = Sheets(i).Name
        i = i + 1
    Next
Next

For j = 1 To r
    For k = 1 To c
        If Sheet(j, k) = 0 Then Sheet(j, k) = ""
    Next
Next
Sheetname = Sheet
End Function

Hiding Rows :

If you want to Hide Rows on Excel Worksheet if any cell value match with Your Criteria in Selection You can use this Code :



Option Compare Text
Sub HidingMatchingRows()
Application.ScreenUpdating = False
Dim rng As Range
If TypeName(Selection) = "Range" Then
Set rng = Selection
Else
MsgBox "Select Some Range", vbInformation
Exit Sub
End If
        
        For r = 1 To rng.Rows.Count
            For c = 1 To rng.Columns.Count
                If rng.Cells(r, c).Value = "Rajan" Then rng.Cells(r, c).EntireRow.Hidden = True
                Next
        Next
Application.ScreenUpdating = True
End Sub

Compiling Workbooks :-

If You want to Compile Many Worbooks data in a single Workbook you can use this Code :

Sub Compile()

On Error GoTo Err_Clear:

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Dim Fso As New Scripting.FileSystemObject

Dim Path As String

Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Folder to Pick Downloaded Bills"

Application.FileDialog(msoFileDialogFolderPicker).Show

Path = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

If Path = "" Then Exit Sub

Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Folder to Save Compiled File"

CompilePath = Application.FileDialog(msoFileDialogFolderPicker).Show

compiledPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

If compiledPath = "" Then Exit Sub

   

   

Dim Counter

Dim File As File

Dim FOlder As FOlder

Dim wb As Workbook

Dim ws As Worksheet

Dim AcWb As Workbook

Set AcWb = ActiveWorkbook

             ActiveWorkbook.Sheets.Add

             ActiveSheet.Name = "Index"

Set FOlder = Fso.GetFolder(Path)

        For Each File In FOlder.Files

             Counter = Counter + 1

             Set wb = Workbooks.Open(Path & File.Name)

               

                            If Application.Ready = True Then

                                

                                 wb.Sheets("Index").Activate

                                 ActiveSheet.UsedRange.Copy

                                  AcWb.Sheets("Index").Activate

                                  Range("A1000000").End(xlUp).Select

                                  ActiveSheet.Paste

                                 Application.CutCopyMode = False

                                 wb.Close

                            End If

        Next

If Counter > 0 Then

AcWb.SaveAs compiledPath & "Compiled", xlExcel12

AcWb.Close

End If

Err_Clear:

Err.Clear

Resume Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True

        If Counter < 1 Then

        MsgBox "No File Found For Compile", vbInformation

        Else

        MsgBox Counter & " File Has been Compiled, Please Find your File at" & vbCrLf & compiledPath, vbInformation

        End If

       

End Sub

Delete Comments :

If You want to Delete All Comments From a Worksheet , Try this :


Sub delComment()
Dim cmt As Comment
For Each cmt In ActiveSheet.Comments
cmt.Delete
Next cmt
End Sub

Toggle Comment Box

IF you want to toggle Comment box to  Visible/Hide ,you can use this Code :


Sub ToggleComments()
On Error Resume Next
Dim count As Integer
count = ActiveSheet.Comments.count
If count = 0 Then MsgBox "There is no comment"
    If Application.DisplayCommentIndicator = xlCommentAndIndicator Then
        Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    Else
        Application.DisplayCommentIndicator = xlCommentAndIndicator
    End If
End Sub

Count Comments On A Worksheet

How to Count the comment on a Worksheet :


Sub CountComment()
On Error Resume Next
Dim cmt As Comment
Dim count As Integer
count = 0
For Each cmt In ActiveSheet.Comments
count = count + 1
Next cmt
If count = 0 Then
MsgBox "There is no Comment in Active Worksheet"
Else
MsgBox "Total Comment in active sheet = " & count
End If
End Sub

Concatenation of All String in Selection

if you want to Concatenate Some Data you can use this Code :

Sub ConcateAll()

    Dim Resultcell As Range

    Dim rng As Range

    Dim cell As Range

    Dim resultString As String

    Set rng = Application.InputBox("Please select A Range For Input ", , , , , , , 8)

    Set Resultcell = Application.InputBox("Please select A Range For Out ", , , , , , , 8)

    resultString = ""

    For Each cell In rng

        resultString = resultString & " " & cell.Value

    Next

    Resultcell = resultString

End Sub

Get Unique List : Another Method

if You want to get Unique list from a Range ,You ca use this array Function :

Function GetUniqueList(rng As Range) As Variant

On Error Resume Next
 
    Dim Arr() As Variant
    Dim cell As Range
    Dim r, c As Integer
    Dim i, j As Integer
    i = 0: j = 0
   
    With Application.Caller
    r = .Rows.Count
    c = .Columns.Count
    End With
    ReDim Arr(r - 1, c - 1)

    For Each cell In rng
    If WorksheetFunction.CountIf(rng.Cells(1, 1).Resize(cell.Row, 1), cell.Value) = 1 Then
        Arr(i, j) = cell.Value
        If j = c Then j = j + 1
        i = i + 1
        End If
       
     For k = i To UBound(Arr())
     Arr(k, 0) = ""
     Next
    Next
    GetUniqueList = Arr
End Function

Matching Data With in 2 Range :

if You want to Match the Data Between Two Range, You can use this Macro : 

Both Range must be Same,

Sub matchValue()

On Error resume Next

Application.ScreenUpdating = False

Dim F_range As Range

Dim S_range As Range

Set F_range = Application.InputBox("Please Select 1st Range", , , , , , , 8)

Set S_range = Application.InputBox("Please Select 2nd Range", , , , , , , 8)

Dim r As Integer

Dim c As Integer

r = F_range.Rows.Count

c = F_range.Columns.Count

Dim cc As Integer

Dim rc As Integer

For cc = 1 To c

For rc = 1 To r

'For Each cell In F_range.Cells

If F_range.Cells(rc, cc).Value = S_range.Cells(rc, cc).Value Then

Else

F_range.Cells(rc, cc).Font.Bold = True

F_range.Cells(rc, cc).Color = 2

F_range.Cells(rc, cc).Interior.ColorIndex = 31

S_range.Cells(rc, cc).Font.Bold = True

S_range.Cells(rc, cc).Interior.ColorIndex = 31

End If

Next rc

Next cc

Application.ScreenUpdating = True

Range("A1").Select

End Sub

Extract Unique List :

if you want to Extract Unique Value From a List , you can use this UDF :

Function UniqueList(rng As Range, Pos As Long) As String Dim List() As String

    Dim cell As Range

    Dim i As Long

    Dim t As Long

    i = 0

ReDim List(rng.Cells.Count) As String

For Each cell In rng

flag = 0

                    For t = LBound(List) To UBound(List)

                       If cell.Value = List(t) Then

                 

                        flag = 1

                        Exit For

                        End If

                        Next

                           

                            If flag = 0 Then

                            List(i) = cell.Value

                            i = i + 1

                            End If

Next

UniqueList = List(Pos)

End Function

Adding Custom Menus In Excel :

If You want to add Custom Manus in Excel you can Write a program like this :



Private Sub Workbook_Open()
If Application.Version >= 12 Then
On Error Resume Next
Dim Cbar As CommandBar


Set Cbar = Application.CommandBars.Add
With Cbar
.Name = "EB_Pro(Version.0.1)"
.Visible = True
.Position = msoBarTop
End With


With Cbar.Controls.Add(msoControlButton)
.Caption = "&DownLoadBill"
.Style = msoButtonCaption
.OnAction = "Module1.DownloadBills"
.Visible = True
.BeginGroup = True
End With




With Cbar.Controls.Add(msoControlButton)
.Caption = "&DownloadPayMent" & vbCrLf & "History"
.Style = msoButtonCaption
.OnAction = "PaymentHistory.DownloadHistory"
.Visible = True
.BeginGroup = True
End With

End Sub

Vlookup Comments :

if you want to Get Comment with Lookup Value in Result Cells , You can use this Code :

Sub VlookupByCodes()

Dim ResultRange As Range

Dim SearchRange As Range

Dim ColNum As Integer

Dim LookUpValue As Range

Dim cellResult As Range

Dim CellSearch As Range

Dim i As Integer

        Set ResultRange = Application.InputBox("Select the Range Where You want Output", , , , , , , 8)

        Set LookUpValue = Application.InputBox("Select the Range of searchable Value", , , , , , , 8)

        Set SearchRange = Application.InputBox("Select the Range to Search Value", , , , , , , 8)

        ColNum = Application.InputBox("Give Colnum")

        i = 1

               

                    For Each cellResult In ResultRange

                            For Each CellSearch In SearchRange

                                    If CellSearch.Value = LookUpValue.Cells(i, 1).Value Then

                                        cellResult.Value = CellSearch.Offset(0, ColNum).Value

                                                If hasComment(CellSearch.Offset(0, ColNum)) = True Then

                                                    cellResult.AddComment

                                                    cellResult.Comment.Visible = True

                                                    cellResult.Comment.Text CellSearch.Offset(0, ColNum).Comment.Text

                                                End If

                                        i = i + 1

                                        Exit For

                                    End If

                            Next

                    Next

Set ResultRange = Nothing

Set LookUpValue = Nothing

Set SearchRange = Nothing

Set cellResult = Nothing

Set CellSearch = Nothing

       

End Sub

Private Function hasComment(cell As Range) As Boolean

On Error GoTo err:

If cell.Comment.Text <> "" Then

hasComment = True

Else

hasComment = False

End If

err:

If err.Number <> 0 Then

hasComment = False

End If

End Function

Remove Special Character from a String :

If You want to Remove Extra Character from you String , You want to Keep only Alphabets and Numeric Character You can use the Below Function :

Public Function SheetName(Shname As String) As String Dim Cod As Integer Dim ShN As String

            For i = 1 To Len(Shname)

                Cod = Asc(Mid(Shname, i, 1))

                        If (Cod > 64 And Cod < 91) Or (Cod > 96 And Cod < 123) Or (Cod > 79 And Cod < 90) Then

                        ShN = ShN & Mid(Shname, i, 1)

                        End If

            Next

            SheetName = ShN

End Function

Copy Data WithOut Decimal Value :

If you want to Copy your date with out Decimal Value You can use this Code :



Option Base 1
Sub CopyPasteWithOutDecimalPlace()




Dim rngCopy As Range
Dim rngPaste As Range
Dim arr() As String
Dim cell As Range
Dim iVal As String
Dim Rw As Integer
Dim Col As Integer
Dim cellvalue As Variant


        Set rngCopy = Application.InputBox("Select the Range to Copy ", , , , , , , 8)
        Set rngPaste = Application.InputBox("Select A cell to Paste the Data", , , , , , , 8)


                ReDim arr(1 To rngCopy.Rows.Count, 1 To rngCopy.Columns.Count)
                        Rw = rngCopy.Rows.Count
                        Cl = rngCopy.Columns.Count
                                        
                       Application.ScreenUpdating = False
                       
                        For r = 1 To Rw
                            For c = 1 To Cl
                                cellvalue = rngCopy.Cells(r, c).Value
                                If WorksheetFunction.IsNumber(rngCopy.Cells(r, c).Value) Then
                                        iVal = Left(cellvalue, WorksheetFunction.Find(".", cellvalue, 1) - 1)
                                        arr(r, c) = iVal
                                    ElseIf IsError(cellvalue) Then
                                            arr(r, c) = CStr(cellvalue)
                                    Else
                                        arr(r, c) = cellvalue
                                End If
                            Next
                        Next




                        
                        rngPaste.Resize(Rw, Cl).Value = arr
                        rngPaste.Resize(Rw, Cl).Value = rngPaste.Resize(Rw, Cl).Value
                        Application.ScreenUpdating = True
End Sub

Return Range Value in Reverse Order :

if you want  Value of selected Range in Reverse Order :

Use of Range.Characters

If you want to highlight Character which meet with your Criteria , You can use the Below Code :

Sub HighLight()

Application.ScreenUpdating = False

On Error Resume Next

    Dim cell As Range

    Dim rng As Range

    Dim st As String

    Dim loc As Integer

Dim n as string

    st = ""

        Set rng = ActiveSheet.UsedRange

            For Each cell In rng

                If cell.Value <> "" Then

                    st = st & cell.Value

                End If

            Next

           

                For i = 1 To Len(st)

                    n = Mid(st, i, 1) & Mid(st, i + 1, 1) & Mid(st, i + 2, 1)

                    If Asc(Mid(n, 1, 1)) > 64 And Asc(Mid(n, 1, 1)) < 91 And Asc(Mid(n, 2, 1)) > 64 And Asc(Mid(n, 2, 1)) < 91 And Asc(Mid(n, 3, 1)) > 64 And Asc(Mid(n, 3, 1)) < 91 Then

                    

                           

                            Cells.Find(What:=n, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _

                            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _

                            , SearchFormat:=False).Activate

                            loc = WorksheetFunction.Find(n, ActiveCell.Value, 1)

                    ActiveCell.Characters(loc, 3).Font.ColorIndex = 26

                    ActiveCell.Characters(loc, 3).Font.Bold = True

                    i = i + 3

                     End If

                Next

               

                Application.ScreenUpdating = True

               

End Sub

Looping in VBA

See the Same Result with Different Type of Loops


 Sub FLoop()
 Dim i As Integer
  Range("A1").Value = "Example By For Loop"
  Range("A2").Select
 
    For i = 1 To 20
                ActiveCell.Value = "i am In For Loop " & i & " time and My value is " & i
                ActiveCell.Offset(1, 0).Select
    Next
 End Sub


 Sub DoLoop()
 Dim i As Integer
  Range("A1").Value = "Example By Do Loop"
  Range("A2").Select
  i = 0
                Do
                i = i + 1
                ActiveCell.Value = "i am In Do Loop " & i & " time and My value is " & i
                ActiveCell.Offset(1, 0).Select
                Loop Until i = 20
   
 End Sub


Sub WhileLoop()
 Dim i As Integer
  Range("A1").Value = "Example By While Loop"
  Range("A2").Select
  i = 0
                While i <> 20
                i = i + 1
                ActiveCell.Value = "i am In While Loop " & i & " time and My value is " & i
                ActiveCell.Offset(1, 0).Select
                Wend
   
 End Sub


Sub LableLoop()
 Dim i As Integer
  Range("A1").Value = "Example By lable and Goto"
  Range("A2").Select
  i = 0
CC:
   
              i = i + 1
                ActiveCell.Value = "i am In Goto Loop " & i & " time and My value is " & i
                ActiveCell.Offset(1, 0).Select
     If i <> 20 Then
     GoTo CC:
     Else
     Exit Sub
     End If
 End Sub

Get Wrong KeyWord On Another Sheets :

If You have Wrong KeyWord in Your data and You want to Get them on Another Worksheet  You can  Use this Code



Public MyTest As Boolean
Public myWord As String
Sub GetText()
On Error Resume Next
            Dim ws As Worksheet
            Dim st As String
            Dim arr() As String
            Dim cell As Range
            
            Set ws = ActiveSheet
            Sheets("WrongWord").Delete
            Sheets.Add.Name = "WrongWord"
            ws.Activate
            st = ""
            
            
            For Each cell In ActiveSheet.UsedRange
                st = st & " " & cell.Value
            Next
            
            arr = Split(st, " ")
                For i = LBound(arr) To UBound(arr)
                    myWord = arr(i)
                    Call mySpell
                        If MyTest = False Then Sheets("WrongWord").Range("A" & Sheets("WrongWord").Range("A20000").End(xlUp).Row + 1).Value = myWord
                        MyTest = False
                Next
                Sheets("WrongWord").Activate
                MsgBox "Total " & WorksheetFunction.CountA(ActiveSheet.Cells) & "  Wrong Word Found in Data ", vbInformation
End Sub
Sub mySpell()
MyTest = Application.CheckSpelling(myWord)


End Sub

Showing Error Description In Status Bar :

Sometime we need to see the Program Execution Status : if you need to see what is Running inside the program you can use status bar to show Massage and Error Description : 


Try the Following Code :





Sub showMsg()
    On Error GoTo Err:
    a = 1 / 0
Err:
    If Err.Number <> 0 Then
    Application.StatusBar = Err.Description
    End If
End Sub

Sub Processing()

For i = 1 To 5

Application.Wait Now + TimeValue("00:00:01")

    Application.StatusBar = "Current Value of I = " & i

Next

End Sub

Generate All Possible Combination :

If you want to Generate All Possible Combination of 9 Digit (1 to 9) , You can use this :

Sub ss()

For One = 1 To 9

    For Two = 1 To 9

        For three = 1 To 9

            For Four = 1 To 9

                For Five = 1 To 9

                    For Six = 1 To 9

                        For Seven = 1 To 9

                            For Eight = 1 To 9

                                For Nine = 1 To 9

                                    ActiveCell.Value = One & Two & three & Four & Five          & Six & Seven & Eight & Nine

                                    If ActiveCell.Row <> 1048576 Then

                                    ActiveCell.Offset(1, 0).Select

                                    Else

                                    ActiveCell.Offset(1, 1).Select

                                    End If

                                   

                                Next

                            Next

                        Next

                    Next

                Next

            Next

        Next

    Next

Next

End Sub