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

Copy Data from Word to Excel By VBA

Sub CopyTextFromWord()

    Dim wApp As Word.Application

    Set wApp = New Word.Application

    wApp.Visible = True

    wApp.Activate

    wApp.Documents.Open "YourFilePath\SampleWord.docx"

    wApp.Selection.WholeStory

    wApp.Selection.Copy

    Range("A1").Activate

    ActiveSheet.Paste

End Sub

Filling Array With Loop :

if you have Data in A1:C5 Range and You Need to Store that in A Variable , You can take help with this Macro :

Option Base 1

Sub StoreInArrya()

    Dim Arr() As Variant

    Dim rng As Range

    Dim Rw As Integer

    Dim Cl As Integer

   

    Set rng = Range("A1:C5")

    ReDim Arr(rng.Cells.Rows.Count, rng.Cells.Columns.Count)

       

            For Rw = 1 To rng.Rows.Count

                    For Cl = 1 To rng.Columns.Count

                    Arr(Rw, Cl) = rng.Cells(Rw, Cl).Value

                    Next

            Next

              

               For Rw = 1 To rng.Rows.Count

                    For Cl = 1 To rng.Columns.Count

                    st = st & vbTab & Arr(Rw, Cl)

                    Next

                    st = st & vbCrLf

                Next

               MsgBox st

End Sub

Debug.Print Statement And Immediate Window

Debug.Print Statement is Very useful Feature in VB which allow us to track the program .. as you can see the ScreenShot.

In this Example , When Error will comes Execution will Go to Err: Label where it will check if  Number of Error Does not equal to Zero if Error Found  Debug.Print Statement Will Print the Error Description on Immediate Window ,

Short Cut to Open Immediate Window is Ctrl+G

2). In this Example OutPut is Generating On Immediate Window,

Adding Controls On Worksheet in RunTime :

If you need to Add Controls On Worksheet in Run Time :


Sub MakeComponentinRunTImeOnSpreadSheet()
On Error Resume Next
Dim cb As OLEObject
n = 5
For i = 1 To 10
 Set cb = ActiveSheet.OLEObjects.Add(classtype:="Forms.Checkbox.1")
                With cb
                    .Top = n
                    .Object.Caption = "Do you want to Select Range"
                    .LinkedCell = Active.Offset(0, 5).Address
                    .Object.Value = False
                    .Visible = True
                End With
                ActiveCell.Offset(1, 0).Activate
                Set cb = Nothing
                n = n + 20
Next
End Sub

Make Component In Run Time :

Sometime we need to Create UserForm Component at Run Time , We can do this By Following Codes :




Sub AddInRunTime()
'On Error Resume Next
Dim Cb As Control
    ThisWorkbook.VBProject.VBComponents.Add vbext_ct_MSForm
        Set Cb = ThisWorkbook.VBProject.VBComponents("UserForm1").Designer.Controls.Add("Forms.CommandButton.1")
        Cb.Left = 50
        Cb.Top = 50
        Cb.Caption = "Click Me"
       
    st = "Private Sub CommandButton1_Click()" & vbCrLf & _
          "MsgBox " & """I Born in Run Time""" & ", vbInformation " & vbCrLf & _
          "End Sub"
         
        ThisWorkbook.VBProject.VBComponents("UserForm1").CodeModule.InsertLines 1, st
        Call Show
End Sub


Sub Show()
UserForm1.Show
End Sub

Unzip FilesBy VBA

If you need to Unzip files From a Zip Folder you can use this Codes :


Option Explicit

Sub UnzipAFile()
    Dim ShellApp As Object
    Dim TargetFile
    Dim ZipFolder

'   Target file & temp dir
    TargetFile = Application.GetOpenFilename _
        (FileFilter:="Zip Files (*.zip), *.zip")
    If TargetFile = False Then Exit Sub
   
    ZipFolder = Application.DefaultFilePath & "\Unzipped\"

'   Create a temp folder
    On Error Resume Next
    RmDir ZipFolder
    MkDir ZipFolder
    On Error GoTo 0

'   Copy the zipped files to the newly created folder
    Set ShellApp = CreateObject("Shell.Application")
    ShellApp.Namespace(ZipFolder).CopyHere _
       ShellApp.Namespace(TargetFile).items

    If MsgBox("The files was unzipped to:" & _
       vbNewLine & ZipFolder & vbNewLine & vbNewLine & _
       "View the folder?", vbQuestion + vbYesNo) = vbYes Then _
       Shell "Explorer.exe /e," & ZipFolder, vbNormalFocus
End Sub

How to Zip File by VBA

If You want to Zip any Files Use this Code :

Option Explicit

Sub ZipFiles()
    Dim ShellApp As Object
    Dim FileNameZip As Variant
    Dim FileNames As Variant
    Dim i As Long, FileCount As Long

'   Get the file names
    FileNames = Application.GetOpenFilename _
        (FileFilter:="All Files (*.*),*.*", _
         FilterIndex:=1, _
         Title:="Select the files to ZIP", _
         MultiSelect:=True)

'   Exit if dialog box canceled
    If Not IsArray(FileNames) Then Exit Sub
 
    FileCount = UBound(FileNames)
    FileNameZip = Application.DefaultFilePath & "\compressed.zip"
   
    'Create empty Zip File with zip header
    Open FileNameZip For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1

    Set ShellApp = CreateObject("Shell.Application")
    'Copy the files to the compressed folder
    For i = LBound(FileNames) To UBound(FileNames)
        ShellApp.Namespace(FileNameZip).CopyHere FileNames(i)
    Next i

    'Keep script waiting until Compressing is done
    On Error Resume Next
    Do Until ShellApp.Namespace(FileNameZip).items.Count = FileCount
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
   
    If MsgBox(FileCount & " files were zipped to:" & _
       vbNewLine & FileNameZip & vbNewLine & vbNewLine & _
       "Do you want to view the zip file?", vbQuestion + vbYesNo) = vbYes Then _
       Shell "Explorer.exe /e," & FileNameZip, vbNormalFocus
End Sub

Embaded Flash Object in Excel :

Follow the Process - When you need a flash File in Your Excel Sheet.

1). Insert the Shock wave Flash Object In your Excel Workhseet

2). Download or make Your  .Swf file and save it on Hard Drive.
3). Right Click on ShockWave Flash Object and Click to Properties
3) do Enable Movie Option  = True
4) Give the Path of .Swf File in Movie Property

After Doing all that Process Click on Design Tools You will Find result as Below Image :

Vlookup By VBA

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
                                        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

Power Point to Excel

Copy Power Point  Table Data into Excel.


Sub PowerPointToExcel()

'PowerPoint To Excel
Dim ppt As PowerPoint.Application
Set ppt = New PowerPoint.Application
ppt.Visible = msoTrue
Dim sh As Worksheet
ppt.Presentations.Open "D:\ppt1.pptm"

For j = 1 To ppt.ActivePresentation.Slides.Count
       
        For i = 1 To ppt.ActivePresentation.Slides(j).Shapes.Count
                ppt.ActivePresentation.Slides(i).Shapes(i).Copy
                ActiveSheet.Paste
                Range("A" & ActiveSheet.UsedRange.Rows.Count + 2).Select
        Next
Next

End Sub

Access To Excel and Excel to Access to VBA

Access to Excel Data Retrieving :


'SearchButton
Private Sub CommandButton1_Click()
On Error GoTo Err:

Application.StatusBar = "Connecting...."
Dim sh As Worksheet
Dim cn As ADODB.Connection, rs As New ADODB.Recordset, r As Long
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
    "Data Source=\\192.168.1.159\D\ReceiptDataBase.accdb;"
   
    rs.Open "Sheet1", cn, adOpenStatic, adLockOptimistic, adCmdTable
Set sh = Sheets("InterFace")

c = 0
While Not rs.EOF = True
        If rs.Fields("IndusID") = sh.Range("InID").Value And IsNull(rs.Fields("PaidAt").Value) Then
       
        rw = sh.Range("A100").End(xlUp).Row + 1
            For Each f In rs.Fields
            sh.Cells(rw, c + 1).Value = rs.Fields(c).Value
            c = c + 1
            Next
           
        End If
        rs.MoveNext
 Wend
 Set cn = Nothing
 Set rs = Nothing
Exit Sub
Err:
If Err.Number > 0 Then
    MsgBox "Connection Error", vbInformation
    End If

End Sub


Update Query From Excel To Access

' Updated Button
Private Sub Upldate_Click()

On Error GoTo Err:

Application.StatusBar = "Connecting...."
Dim sh As Worksheet
Dim Rng As Range
Dim cell As Range
Dim Sql As String
Dim cn As ADODB.Connection, rs As New ADODB.Recordset, r As Long
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
    "Data Source=\\192.168.1.159\D\ReceiptDataBase.accdb;"
Set sh = Sheets("interFace")
Set Rng = sh.Range("J5:J" & Range("A100").End(xlUp).Row)
        If Rng.Row = 4 Then Exit Sub

    For Each cell In Rng
    If cell.Value <> "" Then
    Sql = "Update  Sheet1 Set PaidAt=" & Range("I" & cell.Row).Value & ",PaidDate='" & Range("J" & cell.Row).Value & "',ReceiptNumber=" & Range("K" & cell.Row).Value & ", Remark =' " & Range("L" & cell.Row) & "' where EneryUsageID =" & Range("B" & cell.Row)
    cn.Execute Sql, "Sheet1"
    Rows(cell.Row).Delete
    MsgBox "Updated"
    End If
    Next

 Set cn = Nothing
 Set rs = Nothing
Exit Sub
Err:
End Sub

Attach ActiveWorkbook to OutLook mail

Sub AttachedActiveWorkbookToMail()
    Application.Dialogs(xlDialogSendMail).Show
End Sub

Drive information :

Getting Drive Information In Excel :


Private Declare Function GetDriveType32 Lib "kernel32" _
    Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
  Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _
  ByVal lpBuffer As String) As Long

Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" _
    (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, _
    lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long

Function DriveType(DriveLetter As String) As String
'   Returns a string that describes the drive type
    DLetter = Left(DriveLetter, 1) & ":"
    DriveCode = GetDriveType32(DLetter)
    Select Case DriveCode
        Case 1: DriveType = "Local"
        Case 2: DriveType = "Removable"
        Case 3: DriveType = "Fixed"
        Case 4: DriveType = "Remote"
        Case 5: DriveType = "CD-ROM"
        Case 6: DriveType = "RAM Disk"
        Case Else: DriveType = "Unknown"
    End Select
End Function


Function NumberofDrives() As Integer
'   Returns the number of drives
    Dim Buffer As String * 255
    Dim BuffLen As Long
    Dim DriveCount As Integer
 
    BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
    DriveCount = 0
'   Search for a null -- which separates the drives
    For i = 1 To BuffLen
        If Asc(Mid(Buffer, i, 1)) = 0 Then _
          DriveCount = DriveCount + 1
    Next i
    NumberofDrives = DriveCount
End Function


Function DriveName(index As Integer) As String
'   Returns the drive letter using an index
'   Returns an empty string if index > number of drives
   
    Dim Buffer As String * 255
    Dim BuffLen As Long
    Dim TheDrive As String
    Dim DriveCount As Integer
 
    BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)

'   Search thru the string of drive names
    TheDrive = ""
    DriveCount = 0
    For i = 1 To BuffLen
        If Asc(Mid(Buffer, i, 1)) <> 0 Then _
          TheDrive = TheDrive & Mid(Buffer, i, 1)
        If Asc(Mid(Buffer, i, 1)) = 0 Then 'null separates drives
            DriveCount = DriveCount + 1
            If DriveCount = index Then
                DriveName = UCase(Left(TheDrive, 1))
                Exit Function
            End If
            TheDrive = ""
        End If
    Next i
End Function


Sub ShowDriveInfo()
'   This sub writes information for all drives
'   to a range of cells
'   Demonstrates the use of the custom drive functions

    Dim cuAvailable As Currency
    Dim cuTotal As Currency
    Dim cuFree As Currency
   
    Dim i As Integer
    Dim DLetter As String
    Dim NumDrives As Integer
       
    NumDrives = NumberofDrives()

'   Write info for all drives to active cell location
    Cells.ClearContents
    If TypeName(Selection) <> "Range" Then
        MsgBox "Select a cell"
        Exit Sub
    End If
   
'   Insert headings
    Application.ScreenUpdating = False
    With ActiveCell
        .Offset(0, 0).Value = "Drive"
        .Offset(0, 1).Value = "Type"
        .Offset(0, 2).Value = "Total Bytes"
        .Offset(0, 3).Value = "Used Bytes"
        .Offset(0, 4).Value = "Free Bytes"
       
'   Insert data for each drive
    For i = 1 To NumDrives
        DLetter = DriveName(i) & ":\"
        cuAvailable = 0
        cuTotal = 0
        cuFree = 0
        Call GetDiskFreeSpaceEx(DLetter, cuAvailable, cuTotal, cuFree)
   
'       Drive name
        .Offset(i, 0).Value = DLetter
'       Drive type
        .Offset(i, 1) = DriveType(DLetter)
'       Total space
        .Offset(i, 2) = Format(cuTotal * 10000, "#,###")
'       Used space
        .Offset(i, 3) = Format((cuTotal - cuFree) * 10000, "#,###")
'       Free space
        .Offset(i, 4) = Format(cuFree * 10000, "#,###")

    Next i
'   Format the table
    ActiveSheet.ListObjects.Add xlSrcRange, ActiveCell.CurrentRegion
    With ActiveCell.ListObject
        .TableStyle = "TableStyleLight8"
        .ShowTableStyleRowStripes = False
        .ShowTableStyleColumnStripes = True
    End With
    .CurrentRegion.Columns.AutoFit
    End With 'ActiveCell
End Sub

Get Key Status :

How To Know HOT Key Status ... if they are pressed or Not??

'declare window API's Function
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

'   Constants for the keys of interest
    Const VK_SHIFT As Integer = &H10
    Const VK_CONTROL As Integer = &H11
    Const VK_MENU As Integer = &H12 'Alt key


Sub DisplayKeyStatus()
    Dim TabChar As String * 1
    Dim CRChar As String * 1
    Dim Shift As Boolean, Control As Boolean, Alt As Boolean
    Dim Msg As String
   
    TabChar = Chr(9)
    CRChar = Chr(13)

'   Use API calls to determine which keys are pressed
    If GetKeyState(VK_SHIFT) < 0 Then Shift = True Else Shift = False
    If GetKeyState(VK_CONTROL) < 0 Then Control = True Else Control = False
    If GetKeyState(VK_MENU) < 0 Then Alt = True Else Alt = False

'   Build the message
    Msg = "Shift:" & TabChar & Shift & CRChar
    Msg = Msg & "Control:" & TabChar & Control & CRChar
    Msg = Msg & "Alt:" & TabChar & Alt & CRChar
   
'   Display message box
    MsgBox Msg, vbInformation, "Key Status"
End Sub

Binary Combination :

If You want to make binary Digit Combination . You can use this  Macro :-

Sub MakeCobmination()

Application.ScreenUpdating = False
    Dim t As Double
    Dim Digit As Double
    Dim SS As Double
    Dim j As Double
    Combination = InputBox("Enter Digit ")
    SS = 2 ^ Combination
   
    If Val(Combination) > 20 Then
        MsgBox "you Can give till 20 ", vbInformation
        Exit Sub
    End If
    t = 1
    n = 1
    lp = 1
    j = 1
    Cells.ClearContents
   
For lp = 1 To Combination
            For n = 1 To SS / lp * 2
            For i = 1 To lp
            Cells(j, lp).Value = 0
            j = j + 1
        Next

                For i = 1 To lp
                        Cells(j, lp).Value = 1
                        j = j + 1
                Next

Cells(j, lp).Select
    If ActiveCell.Row >= SS + 1 Then Exit For
    Next
j = 1
Next
                Range("A" & Range("A65536").End(xlUp).Row + 1).Resize(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.Columns.Count).ClearContents
                  C = ActiveSheet.UsedRange.Columns.Count
                  R = ActiveSheet.UsedRange.Rows.Count
               
                For H = 1 To R
                    For M = 1 To C
                    st = st & Cells(H, M).Value
                    Next
                    Cells(H, C + 1).Value = "'" & st
                    st = ""
                Next
Range("A1").Resize(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count - 1).Columns.Delete
Application.ScreenUpdating = True
End Sub

Creating Codes By Codes

How to Create and manipulate Exist Code in VBA CodeModule:-


Sub ss()
Dim sh As Worksheet
Set sh = ActiveSheet
Dim wb As Workbook
Set wb = Workbooks("Book1")
        For i = 1 To sh.OLEObjects.Count
                Set sh = ActiveSheet
                wb.VBProject.VBComponents(sh.Name).CodeModule.AddFromString ("'Private Sub DTPicker" & i & "_Change()")
                wb.VBProject.VBComponents(sh.Name).CodeModule.AddFromString ("Range(""A" & i & """)" & ".Value = Me.DTPicker" & i & ".Value")
                wb.VBProject.VBComponents(sh.Name).CodeModule.AddFromString ("End Sub")
        Next
n = 0
                    For t = 1 To ThisWorkbook.VBProject.VBComponents(sh.Name).CodeModule.CountOfLines Step 3
                        n = n + 1
                    wb.VBProject.VBComponents(sh.Name).CodeModule.ReplaceLine t, "Private Sub DTPicker" & n & "_Change()"

Next
End Sub

How to Use ParamArray :

Use of ParamArray :-

Param array is the collection of variant type variable : its allow to pass Voluntarily Variable to a Function, See the Below Mention Ratio Function, We can give any number of Arguments to this Function and can get Ratio:

Function Ratio(ParamArray arr()) As String

Dim Arr2(1) As Integer

        For i = 0 To UBound(arr)

            Ratio = Ratio & arr(i) / WorksheetFunction.Gcd(arr) & ":"

        Next

        Ratio = Left(Ratio, Len(Ratio) - 1)

End Function

Changing Date Format:

if you have date in below Mention Format :

24/12/11
21/1/11
30/9/11

and you want to Convert it on Regular Date format, You can use below mention Function For the Same

=Redate()



Function Redate(dat As String, div As String)
 ' Defining variables
   Dim da As String
   
    Dim mo As String
   
    Dim fst As String
       
        Dim chr As String
       
        Dim pos As Integer
   
        Dim leng As Integer
       
        Dim ch As String
leng = Len(dat)
For pos = 1 To leng
ch = Mid(dat, pos, 1)
If ch = div Then
fst = pos
pos = leng
Else
pos = pos + 0
End If
Next pos
Dim ch2 As String
Dim Sc As Integer
Dim pos2 As Integer
For pos2 = 1 To leng
ch2 = Mid(dat, pos2, 1)
If ch2 = div Then
Sc = pos2
End If
Next pos2
chr = (Sc - 1) - (fst)
mo = Mid(dat, fst + 1, chr)
Dim y As String
da = Left(dat, fst - 1)
y = Mid(dat, Sc + 1, leng - Sc)
If dat = "" Then
Redate = " "
Else
Redate = mo & "/" & da & "/" & y
End If
End Function

Clear Clip Board :

Clear Clip Board By VBA:-

Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long

Sub ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Sub

Hiding Data On Worksheet : Custom Format

if You want to Hide your data on Worksheet  You can use the Custom Format ";;;" , After apply this Format Your data will not be visible.

Creating HyperLinks of All Sheets :

If you want to make Quick Hyperlinks of All Sheets on a Single Sheets.. You can Try this :


Sub CreatingHyperLink()
For i = 1 To Sheets.Count
ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & i), Address:="", SubAddress:= _
        Sheets(i).Name & "!A1", TextToDisplay:=Sheets(i).Name
Next
End Sub

Size of Excel Worksheet :-

How Big Is a Worksheet?

It's interesting to stop and think about the actual size of a worksheet. Do the arithmetic (16,384 ×
1,048,576), and you'll see that a worksheet has 17,179,869,184 cells. Remember that this is in
just one worksheet. A single workbook can hold more than one worksheet. If you're using a 1024 × 768 video mode with the default row heights and column widths, you can  see 15 columns and 25 rows (or 375 cells) at a time - which is about .000002 percent of the entire worksheet. In other words, more than 45 million screens of information reside within a single worksheet.If you were to enter a single digit into each cell at the relatively rapid clip of one cell per second, it would take you about 545 years, nonstop, to fill up a worksheet. To print the results of your efforts would require more than 40 million sheets of paper - a stack more than a mile high. As you might suspect, filling an entire workbook with values is not possible. It's not even close to
being possible. You would soon run out of memory, and Excel would probably crash.You have complete control over the column widths and row heights - in fact, you can even hide rows and
columns (as well as entire worksheets). You can specify any font size, and you have complete control over
colors. Text in a cell can be displayed vertically (or at an angle) and can even be wrapped around to occupy
multiple lines. NEW In the past, Excel was limited to a palette of 56 colors. With Excel 2007, the number of
colors is  virtually unlimited. In addition, Excel 2007 supports document themes. A single click lets you
apply a new theme to a workbook, which can give it an entirely different look.

Creating Pivot Table :-

Sub Create_Pivot_Table_From_Cache()

Dim oPC As PivotCache
Dim oPT As PivotTable

Set oPC = ActiveWorkbook.PivotCaches.Create(xlDatabase, ActiveSheet.UsedRange)
Sheets.Add.Name = "Pivot"
oPT = oPC.CreatePivotTable(ActiveSheet.Range("A1"), "Pivot1", True)

End Sub

Compiling Workbooks :-

if you have Many Workbooks with Data in Same Format and You want to Compile all them with in a Single workbook you can use below Mention 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)
                                 wb.Sheets("Index").Activate
                             
                                 ActiveSheet.UsedRange.Copy
                                  AcWb.Sheets("Index").Activate
                                  Range("A1000000").End(xlUp).Select
                                  ActiveSheet.Paste
                                 Application.CutCopyMode = False
                                 wb.Close
        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

Compiling Worksheets : -

Sub CompileWOrksheets()
    Dim wksSheet As Worksheet
    With ThisWorkbook
    .Worksheets.Add.Name = "Compiled"
    For Each wksSheet In .Worksheets
        If wksSheet.Name <> "Compiled" Then
            wksSheet.UsedRange.Copy .Worksheets("Compiled").Range("A" & .Worksheets("Compiled").Range("A" & Rows.Count).End(xlUp).Row + 1)
        End If
    Next wksSheet
    End With
End Sub

Sheet Sorter

Sort your sheets in Alphabets Order..

Sub SheetSorter()
Application.ScreenUpdating = False
Application.EnableCancelKey = xlDisabled

Dim count As Integer
Dim ws As Worksheet
Dim oldactive As Object
Dim ws1 As Worksheet
Dim sheetName1 As String

If ActiveWorkbook.ProtectStructure = True Then
        MsgBox "Workbook is protected "
        Exit Sub
End If
Set oldactive = ActiveSheet

If ActiveWorkbook Is Nothing Then Exit Sub

Application.DisplayAlerts = False
           
            For Each ws In Worksheets
                If ws.Name = "SheetData" Then ws.Delete
            Next ws

Worksheets.Add.Name = "SheetData"
count = ActiveWorkbook.Sheets.count
Worksheets("Sheetdata").Activate
Dim i As Integer
            For i = 1 To count
                ActiveCell.value = Sheets(i).Name
                Worksheets("Sheetdata").Range("A1").Offset(i, 0).Select
            Next i

Cells.Sort key1:=Range("A1")
Worksheets("Sheetdata").Activate
Worksheets("Sheetdata").Range("A1").Select
               
                For i = 1 To count
                        Worksheets(ActiveCell.value).Move _
                        before:=Worksheets("SheetData")
                        Worksheets("Sheetdata").Activate
                        Range("A1").Offset(i, 0).Activate
                Next i
               
Worksheets("Sheetdata").Delete
oldactive.Activate
Application.ScreenUpdating = True
End Sub

Excel Error Values :

Explanation of Error Returned By An Excel Function :-

#DIV/0!

The formula is trying to divide by 0 (zero) (an operation that’s not
allowed on this planet). This error also occurs when the formula
attempts to divide by a cell that is empty.


#N/A

The formula is referring (directly or indirectly) to a cell that uses the
NA worksheet function to signal the fact that data is not available.
A LOOKUP function that can’t locate a value also returns #NA.


#NAME
The formula uses a name that Excel doesn’t recognize. This can happen
if you delete a name that’s used in the formula or if you have
unmatched quotes when using text. A formula will also display this
error if it uses a function defined in an add-in and that add-in is not

#NULL!
The formula uses an intersection of two ranges that don’t intersect.


#NUM!

There is a problem with a function argument; for example, the SQRT
function is attempting to calculate the square root of a negative
number. This error also appears if a calculated value is too large or
small. Excel does not support non-zero values which are less than
1E-307 or greater than 1E+308 in absolute value.

installed.


#REF! The formula refers to a cell that isn’t valid. This can happen if the cell
has been deleted from the worksheet.


#VALUE!
 The formula includes an argument or operand of the wrong type. An
operand is a value or cell reference that a formula uses to calculate
a result. This error also occurs if your formula uses a custom VBA
worksheet function that contains an error

Converting Text Case in Excel VBA :-

If You want to Convert Text Case in Selection :-

Sub ConvertProperCase()
Application.ScreenUpdating = False
    Dim Rng As Range
    For Each Rng In Selection.Cells
        If Rng.HasFormula = False Then
             'Use this line for ProperCase text; change UCase to LCase for LowerCase text.
            Rng.value = Application.Proper(Rng.value)
        End If
    Next Rng
End Sub

Sub ConvertLowerCase()
Application.ScreenUpdating = False
    Dim Rng As Range
    For Each Rng In Selection.Cells
        If Rng.HasFormula = False Then
             'Use this line for LowerCase text; change UCase to LCase for LowerCase text.
            Rng.value = LCase(Rng.value)
        End If
    Next Rng
End Sub

Sub ConvertUpperCase()
Application.ScreenUpdating = False
    Dim Rng As Range
    For Each Rng In Selection.Cells
        If Rng.HasFormula = False Then
             'Use this line for UpperCase text; change UCase to LCase for LowerCase text.
            Rng.value = UCase(Rng.value)
        End If
    Next Rng
End Sub

Saving Msgbox Answer in A Variable

Sub Result()
ans = MsgBox("Do you want to Continue", vbYesNo)
If ans = vbYes Then MsgBox "You have selected yes", vbInformation
End Sub