Search This Blog

Friday 14 September 2012

RESTRICT USER TO MOVE YOUR USERFORM

Use below codes to restrict the users to move your userform.

1) Declare variables

Private m_sngAnchorLeft As Single
Private m_sngAnchorTop As Single
Private m_blnSetAnchor As Boolean


2) Paste the below code in the Activate event of the userform

Private Sub UserForm_Activate()
If Me.Visible Then
        If Not m_blnSetAnchor Then
            m_sngAnchorLeft = Me.Left
            m_sngAnchorTop = Me.Top
            m_blnSetAnchor = True
        End If
    End If
End Sub

3) Paste the below code in the Deactivate event of the userform

Private Sub UserForm_Deactivate()
m_blnSetAnchor = False
End Sub

4) Paste the below code in the Layout event of the userform

Private Sub UserForm_Layout()
If m_blnSetAnchor Then
        Me.Left = m_sngAnchorLeft
        Me.Top = m_sngAnchorTop
    End If
End Sub

Note: All the above codes should be used


DISABLE CLOSE("X") BUTTON OF USERFORM


To disable the close(X) button of userform paste the below code on the QueryClose event of your userform.


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
Cancel = True
MsgBox "The X is disabled, please use a button on the form.", vbCritical
End If
End Sub

Sunday 19 August 2012

CREATE FUNNEL CHART USING FORMULA


Following are the Steps:

1. Sort your data in Descending Order
2. Enter formula in C2  =REPT("|",B2/50) and drag it down
3.Choose the color that you want.

CHANGE TIME FORMAT FROM "HH:MM Hrs" TO "HH:MM:SS"


Formula in B2:
=TEXT(LEFT(A2,2)/24+MID(A2,4,2)/1440,"hh:mm:ss") and drag it down.


Friday 17 August 2012

FIND AVERAGE OF VALUES EXCLUDING MAX AND MIN VALUE


Formula in A13:
=(SUM(A1:A12)-MIN(A1:A12)-MAX(A1:A12))/(COUNT(A1:A12)-2)

FIND OUT MAXIMUM OCCURED TEXT IN A RANGE



Array formula in B2:
=INDEX($A$2:$A$9,MATCH(MAX(COUNTIF($A$2:$A$9,$A$2:$A$9)),COUNTIF($A$2:$A$9,$A$2:$A$9),0)) with CSE

Monday 13 August 2012

TO FIT THE SIZE OF USERFORM TO YOUR EXCEL WINDOW

Paste the below code in UserForm_Activate procedure and run. It will fit the size of userform to your excel window.


Private Sub UserForm_Activate()
ActiveWindow.WindowState = xlMinimized
With Application
    Me.Top = .Top
    Me.Left = .Left
    Me.Height = .Height
    Me.Width = .Width
End With
End Sub

DATA VALIDATION FOR RESTRICTING DUPLICATE VALUES


Select cell A7 and go to Data Tab, Click on Data Validation, select Custom in Allow field and enter formula in formula field as shown below (Click to enlarge)


Formula:  =ISNA(VLOOKUP(A7,A2:A6,1,FALSE))


Saturday 11 August 2012

ADD ITEMS TO ALL COMBOBOXES OF A USERFORM AT ONE TIME

This is required when you have a number of comboboxes on a userform and you need to add the same list of items to all comboboxes. Instead of adding items one by one to each combobox, you can just use the below code.

Paste this code on userform_intialize event and run.


Private Sub UserForm_Initialize()
Dim nme As Range
  Dim cntrl As Control
  Dim CB As ComboBox
  For Each cntrl In Me.Controls
    If TypeName(cntrl) = "ComboBox" Then
      If CB Is Nothing Then
        For Each nme In Sheet1.Range("MyName")
          cntrl.AddItem nme.Value
          Set CB = cntrl
        Next
      Else
        cntrl.List = CB.List
      End If
    End If
  Next
End Sub

Change highlighted part as per your requirement

ALL SHAPE STYLES

Name Value
msoShape16pointStar 94
msoShape24pointStar 95
msoShape32pointStar 96
msoShape4pointStar 91
msoShape5pointStar 92
msoShape8pointStar 93
msoShapeActionButtonBackorPrevious 129
msoShapeActionButtonBeginning 131
msoShapeActionButtonCustom 125
msoShapeActionButtonDocument 134
msoShapeActionButtonEnd 132
msoShapeActionButtonForwardorNext 130
msoShapeActionButtonHelp 127
msoShapeActionButtonHome 126
msoShapeActionButtonInformation 128
msoShapeActionButtonMovie 136
msoShapeActionButtonReturn 133
msoShapeActionButtonSound 135
msoShapeArc 25
msoShapeBalloon 137
msoShapeBentArrow 41
msoShapeBentUpArrow 44
msoShapeBevel 15
msoShapeBlockArc 20
msoShapeCan 13
msoShapeChevron 52
msoShapeCircularArrow 60
msoShapeCloudCallout 108
msoShapeCross 11
msoShapeCube 14
msoShapeCurvedDownArrow 48
msoShapeCurvedDownRibbon 100
msoShapeCurvedLeftArrow 46
msoShapeCurvedRightArrow 45
msoShapeCurvedUpArrow 47
msoShapeCurvedUpRibbon 99
msoShapeDiamond 4
msoShapeDonut 18
msoShapeDoubleBrace 27
msoShapeDoubleBracket 26
msoShapeDoubleWave 104
msoShapeDownArrow 36
msoShapeDownArrowCallout 56
msoShapeDownRibbon 98
msoShapeExplosion1 89
msoShapeExplosion2 90
msoShapeFlowchartAlternateProcess 62
msoShapeFlowchartCard 75
msoShapeFlowchartCollate 79
msoShapeFlowchartConnector 73
msoShapeFlowchartData 64
msoShapeFlowchartDecision 63
msoShapeFlowchartDelay 84
msoShapeFlowchartDirectAccessStorage 87
msoShapeFlowchartDisplay 88
msoShapeFlowchartDocument 67
msoShapeFlowchartExtract 81
msoShapeFlowchartInternalStorage 66
msoShapeFlowchartMagneticDisk 86
msoShapeFlowchartManualInput 71
msoShapeFlowchartManualOperation 72
msoShapeFlowchartMerge 82
msoShapeFlowchartMultidocument 68
msoShapeFlowchartOffpageConnector 74
msoShapeFlowchartOr 78
msoShapeFlowchartPredefinedProcess 65
msoShapeFlowchartPreparation 70
msoShapeFlowchartProcess 61
msoShapeFlowchartPunchedTape 76
msoShapeFlowchartSequentialAccessStorage 85
msoShapeFlowchartSort 80
msoShapeFlowchartStoredData 83
msoShapeFlowchartSummingJunction 77
msoShapeFlowchartTerminator 69
msoShapeFoldedCorner 16
msoShapeHeart 21
msoShapeHexagon 10
msoShapeHorizontalScroll 102
msoShapeIsoscelesTriangle 7
msoShapeLeftArrow 34
msoShapeLeftArrowCallout 54
msoShapeLeftBrace 31
msoShapeLeftBracket 29
msoShapeLeftRightArrow 37
msoShapeLeftRightArrowCallout 57
msoShapeLeftRightUpArrow 40
msoShapeLeftUpArrow 43
msoShapeLightningBolt 22
msoShapeLineCallout1 109
msoShapeLineCallout1AccentBar 113
msoShapeLineCallout1BorderandAccentBar 121
msoShapeLineCallout1NoBorder 117
msoShapeLineCallout2 110
msoShapeLineCallout2AccentBar 114
msoShapeLineCallout2BorderandAccentBar 122
msoShapeLineCallout2NoBorder 118
msoShapeLineCallout3 111
msoShapeLineCallout3AccentBar 115
msoShapeLineCallout3BorderandAccentBar 123
msoShapeLineCallout3NoBorder 119
msoShapeLineCallout4 112
msoShapeLineCallout4AccentBar 116
msoShapeLineCallout4BorderandAccentBar 124
msoShapeLineCallout4NoBorder 120
msoShapeMixed -2
msoShapeMoon 24
msoShapeNoSymbol 19
msoShapeNotchedRightArrow 50
msoShapeNotPrimitive 138
msoShapeOctagon 6
msoShapeOval 9
msoShapeOvalCallout 107
msoShapeParallelogram 2
msoShapePentagon 51
msoShapePlaque 28
msoShapeQuadArrow 39
msoShapeQuadArrowCallout 59
msoShapeRectangle 1
msoShapeRectangularCallout 105
msoShapeRegularPentagon 12
msoShapeRightArrow 33
msoShapeRightArrowCallout 53
msoShapeRightBrace 32
msoShapeRightBracket 30
msoShapeRightTriangle 8
msoShapeRoundedRectangle 5
msoShapeRoundedRectangularCallout 106
msoShapeSmileyFace 17
msoShapeStripedRightArrow 49
msoShapeSun 23
msoShapeTrapezoid 3
msoShapeUpArrow 35
msoShapeUpArrowCallout 55
msoShapeUpDownArrow 38
msoShapeUpDownArrowCallout 58
msoShapeUpRibbon 97
msoShapeUTurnArrow 42
msoShapeVerticalScroll 101
msoShapeWave 103

CHANGE COMMENT BOX STYLE USING VBA



Paste the below code in the module and run it


Sub Comments_Style()
Dim MyComments As Comment
Dim LArea As Long
For Each MyComments In ActiveSheet.Comments
With MyComments
.Shape.AutoShapeType = msoShapeRoundedRectangle
.Shape.TextFrame.Characters.Font.Name = "Tahoma"
.Shape.TextFrame.Characters.Font.Size = 8
.Shape.TextFrame.Characters.Font.ColorIndex = 2
.Shape.Line.ForeColor.RGB = RGB(0, 0, 0)
.Shape.Line.BackColor.RGB = RGB(255, 255, 255)
.Shape.Fill.Visible = msoTrue
.Shape.Fill.ForeColor.RGB = RGB(58, 82, 184)
.Shape.Fill.OneColorGradient msoGradientDiagonalUp, 1, 0.23
End With
Next
End Sub

Change the shape style, font name, font size, font colour etc. as per your requirement.

To know all shape styles click on:
http://excelvbatipsforbeginners.blogspot.in/2012/08/all-shape-styles.html


Friday 10 August 2012

ENTER DATA ON ALL SHEETS TOGETHER: QUICK TIP

Hold the ctrl key and click on the sheet tabs on which you want to enter the data. Start entering your data and do formatting. Now check the sheets which you have selected. Your data has been entered in all the sheets you have selected with the formatting.

ADD VALUES FROM DIFFERENT SHEETS OF A WORKBOOK WITH A CRITERIA

This is required when we need to add up the values from different sheets to a master sheet with a criteria( Name here).

Example:
Sheet1:
D6: Shweta
E6: 200

Sheet2:
A2: Shweta
B2: 300

Sheet3:
G10: Shweta
H10: 500

Sheet4:
E13: Shweta
F13: Need sum here of all values of "Shweta" from all sheets

Enter formula in F13:
=SUM(SUMIF(INDIRECT("Sheet"&{1,2,3}&"!A:G"),E13,INDIRECT("Sheet"&{1,2,3} &"!B:H")))

Now the question arises what if I have a large number of sheets in my workbook. Say, I need to maintain a different sheet for each day of the month to track the transactions processed by the associates. Hence there are 31 sheets for 31 days of the month.Then it would not be possible to write the sheet number 1,2,3,....31 in the above formula. 

Here is a solution:

Write all the sheet names in a column and give a named range to them. Say MySheets and use below array formula

=SUM(SUMIF(INDIRECT(MySheets & "!A:G"),E13,INDIRECT(MySheets & "!B:H")))
with CSE




WRITE YOUR TEXT IN SHAPES USING VBA

Select a cell (where you want to get the output). Paste the below code in the module and run it.


Sub DrawName()
Const pi = 3.1416
Dim i As Integer
Dim x As Single, y As Single
Dim z As Single
Dim rng As Range
Dim n As Single
Dim k As Integer
Dim sSize As Single
Dim sh As Shape
Dim sName As String
Dim StartLeft As Integer
Dim StartTop As Integer

StartLeft = ActiveCell.Left
StartTop = ActiveCell.Top
sName = InputBox("Enter your text here")
n = 5
k = Len(sName)
sSize = Application.InchesToPoints(0.5)
Randomize Timer
z = 0#
For i = 1 To k
If Mid(sName, i, 1) <> " " Then
x = n * i / k
x = Application.InchesToPoints(x)
If Int(2 * Rnd) = 0 Then
z = z + 0.2
Else
z = z - 0.2
End If
y = Application.InchesToPoints(z)
Set sh = ActiveSheet.Shapes.AddShape _
(msoShapeSun, StartLeft + x, StartTop + y, sSize, sSize)

sh.Fill.ForeColor.RGB = RGB(255, 0, 0)
sh.Fill.Visible = msoTrue
sh.TextFrame.Characters.Text = Mid(sName, i, 1)
sh.TextFrame.Characters.Font.Size = 12
sh.TextFrame.Characters.Font.Name = "Arial"
sh.TextFrame.Characters.Font.Bold = True
sh.TextFrame.Characters.Font.Color = vbBlack
End If
Next i
End Sub

Change the highlighted part to change the shape type. To know all shape types click on:
http://excelvbatipsforbeginners.blogspot.in/2012/08/all-shape-styles.html

After running this code, an inputbox will appear. Enter your text in the inputbox and press enter. Result would be like: (See the image below)


Tuesday 7 August 2012

MOVING TITLE FOR USERFORM


Click on the video to see how it will look like.


Follow the below steps to create a moving title for your userform:

1. Launch Microsoft Excel
2. Press ALT+F11 to open Visual Basic Editor
3. Insert an userform
4. Put a label control on your userform ( say, label 1) and clear the text (delete the text under caption in properties)
5.Put another label (say, label 2) above label 1and write your text in label 2( I wrote "EXCEL VBA TIPS").

See the below image



6. Double click on any userform control, code window will appear.
7. Select "General" as object and paste the below code there as shown in the below image(Click to enlarge)



Code:

Private Sub MoveTitle()
    On Error Resume Next
Again:
    Label2.Left = Label2.Left - 0.05
    DoEvents
    For j = 1 To 50000: Next
    If Label2.Left + Label2.Width < 0 Then Label2.Left = Me.Width
    GoTo Again
End Sub

8. Now select "Userform" as object and "Activate" as procedure and paste the below code there as shown in below image.(Click to enlarge)


Code:

Private Sub UserForm_Activate()
Call MoveTitle
End Sub

Run the userform and your userform title will start moving as shown in the above video.

Did this post help you? Please post your valuable comment. Thanks!!


Sunday 5 August 2012

CHANGE TO SENTENCE CASE


Formula in B2:  =UPPER(LEFT(A2,1))&MID(LOWER(A2),2,999) and drag it down.

Did it help you? Please post your valuable comment. Thanks!!

Saturday 4 August 2012

CREATE IN-CELL BAR CHART IN EXCEL 2007 USING FORMULA- TYPE 2



Enter formula in C4  =REPT("|",B4) and drag it down


Reduce font size to 7 and choose any colour and your chart is ready.

To See Type 1, Click on
http://excelvbatipsforbeginners.blogspot.in/2012/07/create-in-cell-bar-chart-in-excel-2007.html

Did it help you? Please post your valuable comment. Thanks!!


SPLIT CELL CHARACTERS USING VBA



Paste the below code in the module, select the cell you want to split and run the code.


Sub split_cell_char()
Dim i As Integer
For i = 1 To Len(ActiveCell)
ActiveCell.Offset(0, i) = VBA.Mid(ActiveCell, i, 1)
Next
ActiveSheet.UsedRange.Columns.AutoFit
End Sub

Did it help you? Please post your valuable comment. Thanks!!

Friday 3 August 2012

SUM ALL DIGITS OF A CELL USING VBA


Paste the below UDF(User Defined Function) in module and use function.
Function Name  "=sum_cell_values"

Function sum_cell_values(rng As Range)
Dim i As Integer
j = 0
For i = 1 To Len(rng)
j = WorksheetFunction.Sum(j, VBA.Mid(rng, i, 1))
Next
sum_cell_values = j
End Function

Did it help you? Please post your valuable comment. Thanks!

SUM UNIQUE VALUES IN A RANGE



Array formula in B2:

=SUM(IF(FREQUENCY($A$2:$A$10,$A$2:$A$10),$A$2:$A$10))


with CSE

Is this post helpful to you? Please post your valuable comment. Thanks!

Tuesday 31 July 2012

CREATE DYNAMIC DATA VALIDATION LIST


Say your data is in the range A2:A6 and you want to create a data validation list using this data  in C1. It is easy to do. You will go to Data-- Data Validation--List--Select Range--Press OK and you are done.


But sometimes we want our data validation list to get updated automatically when we add entries in our data.
For this we need to create a dynamic named range for our data. To do this go to Formula Tab--Click on Define Name. Below window will appear.


Enter name whatever name you want in the NAME field (I have named it as MyRange) and enter the formula as shown in the figure in refers to field and press OK

Formula :  =OFFSET(Sheet2!$A$1,1,0,COUNTA(Sheet2!$A:$A)-1,1)

Select cell C1(where you want to create data validation list) and Go to Data Tab--Click on Data Validation. Below window will appear


Select List in the combobox under Allow option and enter the name (=MyRange) that you have given in the previous step and press OK.

Now whenever you add an entry in you data, your list will automatically get updated. I have add few names and my list got updated. See image below


Is this post helpful to you?

Please post your valuable comment. Thanks!


Monday 30 July 2012

HOW TO INSERT CAMERA IN QUICK ACCESS TOOLBAR

Below are the steps

1. Click on MS Office button
2. Click on Excel Option
3. Go to Customize
4. Select All Commands
5. Click on Camera and then Add
6. Click OK
(Click to Enlarge)


CONCATENATE YOUR TEXT WITH FORMAT USING EXCEL


STEPS:

1. Enter your text in A1,B1 and C1
2. Adjust column width so that combined width of A1:C1 is equal to the width of E1
3. Select range A1:C1
4. Click on the Camera Tool


5. Select E1 and done.

Now whenever you change the format of any cell (A1,B1 or C1), format of the text in E1 will change automatically.

To know how to insert Camera in Quick Access Toolbar. Click on
How to insert Camera


Is this post helpful to you? Please post your valuable comment.



CREATE IN-CELL BAR CHART IN EXCEL 2007 USING FORMULA- TYPE 1



Formula in F2 to F6:

=REPT("█",A2)&CHAR(10)&REPT("█",B2)&CHAR(10)&REPT("█",C2)&CHAR(10)&REPT("█",D2)&CHAR(10)&REPT("█",E2)

Formatting:

1. Change font size to 3.
2. Wrap Text
3. Go to Format Cells and click on Alignment Tab and Orientation to 90 Degree
4. Select the font color.

AND YOUR INCELL BAR GRAPH IS READY


To see Type 2, Click on
http://excelvbatipsforbeginners.blogspot.in/2012/08/create-in-cell-bar-chart-in-excel-2007.html

Did it help you? Please post your valuable comment. Thanks!!

CREATE AN INDEX FOR YOUR WORKBOOK

Paste the below code in the module and run it


Sub create_index()
Dim i As Integer
Dim newsheet
Dim j As Integer

Set newsheet = Worksheets.Add(before:=Sheets(1))
 
   With newsheet
        .Name = "Index"

            With Range("A1:H1")
                 .Merge
                 .Value = "INDEX"
                 .HorizontalAlignment = xlCenter
                 .VerticalAlignment = xlCenter
                 .Font.Bold = True
                 .Font.Color = vbRed
                 .Font.Size = 13
            End With

j = 2
 
   For i = 2 To ThisWorkbook.Sheets.Count
          .Range("A" & j) = Sheets(i).Name
          .Range("A" & j).Select
          .Hyperlinks.Add Anchor:=Selection, _
            Address:="", SubAddress:="" & Sheets(i).Name & "!A1"

j = j + 1
 
   Next

ActiveWindow.DisplayGridlines = False

    End With

End Sub


This code will insert a sheet in workbook named "Index". This sheet will have list of name of all sheets with hyperlink. You can move to any sheet directly by clicking on it's name.

Thursday 26 July 2012

DELETE ALL SHAPES IN YOUR WORKSHEET


Paste below code in module and run it

Sub delete_shapes()

Dim i As Integer

For i = ActiveSheet.Shapes.Count To 1 Step -1
ActiveSheet.Shapes(i).Delete
Next
End Sub

Monday 23 July 2012

CREATE DATA VALIDATION LIST WITH UNIQUE VALUES FROM A LIST OF DUPLICATES

Paste the below code in module and run it.


Option Explicit

Sub data_validation_with_unique_values()
Dim clctn As New Collection
Dim arr As Variant
Dim i As Integer
Dim distinct() As String

'Fill values from your range into array
arr = Application.Transpose(Sheet1.Cells(1, 1).CurrentRegion.Resize(, 1).Value)

'Create a list of unique
On Error Resume Next
For i = LBound(arr) To UBound(arr)
clctn.Add arr(i), arr(i)
Next i
On Error GoTo 0

ReDim distinct(1 To clctn.Count)
For i = 1 To clctn.Count
distinct(i) = clctn(i)
Next

'Paste unique values in column E
Sheet1.Cells(1, 5).Resize(clctn.Count).Value = Application.Transpose(distinct)

'Give a name range to your list in column E
Range("E1:E" & Range("E65536").End(xlUp).Row).Name = "Myrange"

'Create data validation list in active cell using named range
ActiveCell.Validation.Add xlValidateList, xlValidAlertStop, xlBetween, "=Myrange"

End Sub

Note: Change the highlighted part as per your requirement.

Sunday 22 July 2012

QUICK TIP TO REMOVE "0" FROM ACTIVE WORKSHEET

Click on Office Button



Select Excel Options



Go to Advanced and deselect the checkbox "Show a zero in cells that have zero value as shown in the below figure.(Click on the image to enlarge it)



It will remove all the zero from your worksheet.

Friday 20 July 2012

CLOSE USERFORM ON ESCAPE KEY


Put a commandbutton on your userform and write the below code on command button Click event.


Private Sub CommandButton1_Click()
Unload Me
End Sub

Then set cancel to true in its property. See image below(Click on the image to enlarge it)


Now when you run userform and press escape key on your keyboard, userfrom will be closed.

Is the post useful? Please post your comment and follow my blog:)

PASTE NON BLANK CELLS ONLY USING EXCEL



Array Formula in B1:

=LOOKUP("zzzzz",CHOOSE({1,2},"",INDEX(A:A,SMALL(IF($A$1:$A$10<>"",ROW($A$1:$A$10)),ROWS($B$1:B1)))))      

Press Ctrl+Shift+Enter and drag it down to B10.

Tip:   This is also useful when you create a data validation list from a range with blank cells in it. In that case you can create a new range with non-blank cells using above formula and then use this new range for data validation.


Tuesday 17 July 2012

MERGE TEXT BY VBA WITHOUT LOOSING DATA


Select the cells need to be merged and run the below code in the module.


Sub Merge_without_loosing_data()
Dim OutputText As String
Dim cell As Range
Const delim = " "

On Error Resume Next
For Each cell In Selection
OutputText = OutputText & cell.Value & delim
Next cell

With Selection
     .Clear
     .Cells(1).Value = OutputText
     .Merge
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlCenter
     .WrapText = True
End With
End Sub

SPLIT TEXT BY VBA


Select the cell that you want to split, copy the below code and run it in module.


Sub split_text()
Dim splitval As Variant
Dim totalval As Long

splitval = Split(ActiveCell.Value, Chr(10))
totalval = UBound(splitval)
Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row _
, ActiveCell.Column + 1 + totalval)).Value = splitval
End Sub



Friday 13 July 2012

COUNT "6" WORKING DAYS IN A WEEK

Write 07/08/2012 in A1 and 07/14/2012 in B1

If you use NETWORKDAYS function to count the working days between these two dates, it will give you "5". But what if your office works six days in a week. In that case use the following formula to count six working days in a week.

=SUMPRODUCT(--(WEEKDAY(ROW(INDIRECT(A1&":"&B1)),2)<7))



Thursday 12 July 2012

SORT DATA ON BACKGROUND COLOUR BY VBA


Copy below code and run it in the module


Sub sort_data_on_backgroud_color()
Sheets("Sheet1").Select
Range("B1") = "ColorIndex"
For i = 2 To ActiveSheet.Range("A65536").End(xlUp).Row
ActiveSheet.Range("B" & i).Value = ActiveSheet.Range("A" & i).Interior.ColorIndex
Next
ActiveSheet.Range("A1:B" & Range("A1").End(xlDown).Row).Sort key1:=ActiveSheet.Range("B:B"), order1:=xlAscending, Header:=xlYes
Columns("B:B").ClearContents
End Sub



QUICK TIP: CONVERT THE NUMBER INTO PERCENTILE



If we want to add "%" in each cell in a column, we generally select home tab, then go to % and it converts the number in the following format.

1000%
3300%
3700%
1200%
1100%
4200%
2400%
2400%

So, this is not a right way. The quick way to do this is


Write 100 in a cell & copy itSelect the data which you want to format (In this case A1:A8)
Right click and go to Paste Special
Select divide
Press OK
Go to Home tab and select Percent Style
Your data will change into the format shown in column B in the above image




FIND TOP FIVE VALUES FROM A LIST OF DUPLICATE VALUES


Generally if we use Large function to find out top 5 (any number) values from a list of duplicates it will give
67,65,65,40,40. But if you want to find out the large unique values use below mentioned formula.


Select range from B2:B6 and enter the following formula in the cell B2

=TRANSPOSE(LARGE(IF(FREQUENCY(A2:A11,A2:A11)>0,A2:A11,""),{1,2,3,4,5}))

Press Ctrl+Shift+Enter

GANTT CHART BY VBA



Paste the below code in the module:


Sub gantt_chart()
Dim lastrow, lastcol As Long

lastrow = Range("A65536").End(xlUp).Row
lastcol = Range("A:A").End(xlToRight).Column

Dim i, j As Integer

For j = 5 To lastcol
For i = 2 To lastrow

If Cells(1, j).Value >= Cells(i, 3).Value And Cells(1, j).Value <= Cells(i, 4).Value Then
Cells(i, j).Value = 1
Cells(i, j).Interior.Color = vbRed
Cells(i, j).NumberFormat = ";;;"
Else
Cells(i, j).Value = 0
Cells(i, j).NumberFormat = ";;;"
End If
Next
Next
End Sub

Wednesday 20 June 2012

COUNT UNIQUE ENTRIES FROM A LIST OF DUPLICATE DATA


Formula in B2:

=SUMPRODUCT(1/COUNTIF(A2:A11,A2:A11))

FORMULA TO SUM ALL ODD NUMBERS BETWEEN 1 TO 100

Formulas:

=SUM(2*ROW(OFFSET($A$1,,,100/2))-1) 

Press Ctrl+Shft+Entr

=SUM(ROW(1:100)*MOD(ROW(1:100),2))

Press Ctrl+Shft+Entr

=SUM(ROW(1:100)*ISODD(ROW(1:100)))

Press Ctrl+Shft+Entr

All these formulas can be used for the same purpose

FORMULA TO SUM ALL EVEN NUMBERS BETWEEN 1 TO 100

 Array Formula:

=SUM(ROW(1:100)*ISEVEN(ROW(1:100)))

Press   Ctrl+Shft+Entr.

ADD NUMBERS HAVING TEXT WITH IT


3 Formulas to do this

Formula1 in B2:  =SUMPRODUCT(--SUBSTITUTE(UPPER(G33:G37),"K",""))
Formula2 in B3:  =SUM(--LEFT(G33:G37,LEN(G33:G37)-1))        Press Ctrl+Shft+Enter
Formula3 in B4:  =SUMPRODUCT(--(LEFT(G33:G37,LEN(G33:G37)-1)))    Press Ctrl+Shft+Enter

EXTRACT NUMBERS FROM AN ALPHANUMERIC STRING WHEN NUMBERS ARE NOT CLUSTERED


Alphanumeric StringNumbers
RED458ELT94589
s324rake8ete3248
drk77dFTT563j77563
FKD5RR5
4tryr3514351
3fdffd4f5345
Rkknk4656s4656
9c5vcv933`90923]]9593390923
À87&‰Ã°$ 45§§Ã˜7çz24[8745724
~9¯Å“»~ô855‹eg87Û©3798558737



Array Formula:

=NPV(-0.9,,IFERROR(MID(A58,LEN(A58)-ROW(INDIRECT("1:"&LEN(A58)))+1,1)%,""))

Press Ctrl+Shft+Enter

Friday 27 January 2012

CODE TO PASTE NON BLANK CELLS ONLY


'Selection column A and run the below code in module

Sub PasteNotBlanks()
If Selection.Columns.Count > 1 Then
msgbox "Please selection one column."
Else
Selection.SpecialCells(xlCellTypeConstants).Copy Destination:=Range("B1")
End If
End Sub

CODE TO SELECT ALL DATA ON A WORKSHEET


Sub select_all()
Application.ScreenUpdating = False
Dim mylastrow As Long
Dim mylastcol As Long
Dim mylastcell, myrange
Range("A1").Select
On Error Resume Next
mylastrow = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
mylastcol = Cells.Find("*", [a1], , , xlByColumns, xlPrevious).Column
mylastcell = Cells(mylastrow, mylastcol).Address
myrange = "a1:" & mylastcell
Application.ScreenUpdating = True
Range(myrange).Select
End Sub

CODE FOR CHANGING THE NAME OF COMMAND BUTTON

Private Sub CommandButton1_Click()
If CommandButton1.Caption = "Start" Then
CommandButton1.Caption = "End"
Sheet1.Range("A1").Value = Format(Time, "long time")
ElseIf CommandButton1.Caption = "End" Then
CommandButton2.Caption = "Start"
Sheet1.Range("B1").Value = Format(Time, "long time")
End If
End Sub

CODE FOR HIGHLIGHTING DUPLICATE VALUES

Sub highlight_duplicates()

Dim i, j As Integer
Dim mycheck, rng
Application.ScreenUpdating = False
rng = Selection.Rows.Count
For i = rng To 1 Step -1
mycheck = ActiveCell
ActiveCell.Offset(1, 0).Select
For j = 1 To i
If ActiveCell = mycheck Then
Selection.Font.Bold = True
Selection.Font.ColorIndex = 3
End If
ActiveCell.Offset(1, 0).Select
Next j
ActiveCell.Offset(-i, 0).Select
Next i
Application.ScreenUpdating = True
End Sub

TO FIND OUT THE ADDRESS OF BLANK CELLS WITH A MSGBOX


Sub MsgBoxBlankCells()
  MsgBox Range("A:E").SpecialCells(xlCellTypeBlanks).Address(0, 0)
End Sub

SPLIT DATA FROM ONE SHEET TO MULTIPLE SHEETS

Sub parse_data()

Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

vcol = 2        'CHANGE THE COLUMN NUMBER AS PER YOUR NEED

Set ws = Sheets("Data")        'CHANGE THE SHEET NAME AS PER YOUR NEED

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

title = "A1:Z1"             'CHANGE THE TITLE ROW AS PER YOUR NEED
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count

ws.Cells(1, icol) = "Unique"

For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))

ws.Columns(icol).Clear

For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""

If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If

ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next

ws.AutoFilterMode = False
ws.Activate

End Sub

CODE FOR GETTING THE FILE PATH OF ALL THE FILES IN A FOLDER INTO YOUR EXCELSHEET



Sub get_file_path()
    Dim xRow As Long
    Dim xDirect$, xFname$, InitialFoldr$
    Sheets(1).Select
    InitialFoldr$ = "D:\"       '<<< Startup folder to begin searching from
    Range("A2").Select
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder to list Files from"
        .InitialFileName = InitialFoldr$
        .Show
        If .SelectedItems.Count <> 0 Then
            xDirect$ = .SelectedItems(1) & "\"
            xFname$ = Dir(xDirect$, 7)
            Do While xFname$ <> ""
                ActiveCell.Offset(xRow) = xDirect$ & xFname$
                xRow = xRow + 1
                xFname$ = Dir
            Loop
        End If
    End With
    End Sub

CODE FOR HIGHLIGHTING DUPLICATE VALUES IN DIFFERENT COLORS

Sub Highlight_Duplicate_Entry()
    Dim cel As Variant
    Dim myrng As Range
    Dim clr As Long
    Set myrng = Range("A2:A" & Range("A65536").End(xlUp).Row)
    myrng.Interior.ColorIndex = xlNone
    clr = 3
    For Each cel In myrng
        If Application.WorksheetFunction.CountIf(myrng, cel) > 1 Then
            If WorksheetFunction.CountIf(Range("A2:A" & cel.Row), cel) = 1 Then
                cel.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cel.Interior.ColorIndex = myrng.Cells(WorksheetFunction.Match(cel.Value, myrng, False), 1).Interior.ColorIndex
            End If
        End If
    Next
End Sub