Macro to help remove duplicate rows in excel spreadsheet

Sub duplicate_flg()
' Use to remove duplicates
' Check for duplicates based on columns colx and coly. Customize below.
' flag them in column colflg
' Rowcounts based on column - colx
' ******************************************************
' NEEDs a sorted sheet and assumes a header
' Runs on the active sheet in the active workbook
' ******************************************************

colx = 1
coly = 2
colflg = 3
Cells(1, colflg) = "Is Duplicate?"

lastrowcnt = Cells(Cells.Rows.Count, colx).End(xlUp).Row
'lastrowcnt = 7
ActiveWorkbook.Activate
Set ws = ActiveWorkbook.ActiveSheet

' header assumed. starts from row 2
For i = 2 To lastrowcnt
    If ws.Cells(i, colx) = ws.Cells(i + 1, colx) And _
        ws.Cells(i, coly) = ws.Cells(i + 1, coly) Then
        ws.Cells(i + 1, colflg) = "Y"
    End If
Next i

End Sub

Remove Hyperlinks from excel worksheets

Sub RemoveHyperlink()
'
' Remove Hyperlink from each and every cell of you worksheet
'
'
Dim TotalCols as Integer
Dim TotalRows as Integer

For k = 1 To TotalCols
    For i = 1 To TotalRows
        Cells(i, k).Select
        Selection.Hyperlinks.Delete
    Next
Next
End Sub

Merge excel cell values ; Retain Boundaries

I'm working with excel workbooks for more than 6 hours a day. I needed a quick way to consolidate values of selected cells of a column in the top most row.
e.g.
To merge values of cells 41 to 45 of column B, select the cells and hit the macro. All the values will be consolidated in cell 41.

Sub concate_cell_values()
' This macro consolidates the values
' of the "selected" cells in the top most cell
' Respects cell boundaries

Dim Rng1 As Range
Dim op As String
Dim col, ro As Integer
col = 0
ro = 0

Set Rng1 = Selection

For Each cell In Rng1
  cell.Activate
  If col = 0 Then
     col = ActiveCell.Column
     ro = ActiveCell.Row
  End If
  op = op & cell & " "
Next cell

Cells(ro, col).Value = Trim(op)

End Sub

vba - upper case

ucase('string')

and for lowercase
lcase("string")

Function that returns value in VBA

To code a function that returns value to the calling sub, use FunctionName as the VariableName in the function.

e.g.
function findrownbr()
findrownbr=10
end function

sub readCellData ()
cell_nbr = findrownbr()
msgbox Range("A" &cell_nbr)
end sub

Newline Character in VBA

Chr(13) inserts a new line character in vb.

Output
there is
newline between this and the line above.

Code
"there is a" & Chr(13) & "newline between this and the line above."

Note
Chr(13) should not be in quotes.

Reduce Font in excel with a shortcut key

In MS Word one can use
ctrl + [ to reduce font size
ctrl + ] to increase font size

These do not work in MS Excel.

Following macro reduces any given font size by 2 units. Assign it to a shortcut key e.g. ctrl + p and you're set.

Sub reduceFont()
With Selection.Font
.Size = .Size - 2
End With
End Sub

Filter rows based on Color

Sometimes we work with excel sheets that have color coded rows and we often want to look at only a particular color at a time.

Following vba code does just that. Select any one cell of the color that you want to see. And run the macro filter_on_color. Make sure that column EZ is blank.

Sub filter_on_color()
' Select any color based on which to filter the sheet
' make sure EZ is empty

colindex = Selection.Cells.Interior.ColorIndex
col = ColumnLetter(Selection.Column)
lastrowcnt = Cells(Cells.Rows.Count, "A").End(xlUp).Row

MsgBox "Filtering on cell " & (col & Selection.Row)

For i = 1 To lastrowcnt
If Range(col & i).Cells.Interior.ColorIndex = colindex _ 
Then
Range("EZ" & i) = "Filter on color"
Else
Range("EZ" & i) = ""
End If
Next i

ActiveSheet.Select
Cells.Select
Selection.AutoFilter
Selection.AutoFilter Field:=156,  _ 
Criteria1:="Filter on color"
Range("A1").Select

End Sub

---------------------------------------------------------------------------------------

Function ColumnLetter(ColumnNumber As Integer) As String
' This function is taken from 
' http://www.freevbcode.com/ShowCode.asp?ID=4303

If ColumnNumber > 26 Then

' 1st character: Subtract 1 to map the characters to 0-25,
' but you don't have to remap back to 1-26
' after the 'Int' operation since columns
' 1-26 have no prefix letter

' 2nd character: Subtract 1 to map the characters to 0-25,
' but then must remap back to 1-26 after
' the 'Mod' operation by adding 1 back in
' (included in the '65')

ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
Chr(((ColumnNumber - 1) Mod 26) + 65)
Else
' Columns A-Z
ColumnLetter = Chr(ColumnNumber + 64)
End If
End Function

Index Sheet in Workbook

This vba code creates a new first sheet called index. Index sheet contains serial number and names with hyperlinks of the worksheets in the workbook.

Sub create_index()

' Creates a new sheet called index and 
' makes it the first sheet.
' This macro counts the number of sheet and 
' creates a hyperlink to the sheet and 
' places in index sheet

flg = 1

For Each varsheet In Worksheets
If varsheet.Name = "Index" Then
flg = 0
Exit For
End If
Next varsheet

If flg = 0 Then
MsgBox "Index Exists"
Else
MsgBox "Adding Index"
Worksheets.Add.Name = "Index"
'updated on 05/12
'Worksheets.Move before:=Worksheets(1) 
Worksheets("Index").Move before:=Worksheets(1)
sheetcnt = ActiveWorkbook.Sheets.Count

For i = 2 To sheetcnt
Sheets("Index").Select
j = i + 3
Range("E" & j) = i - 1
Range("F" & j) = Sheets(i).Name
Range("F" & j).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & _
Range("F" & j).Value & "'!A1"
Next i
End If

End Sub

Using Excel Functions in VBA - vlookup

Say we have a Sheet1 with following data :

COL A	COL B
bat	ball
cat	mouse
zebra	crossing

To look up content of COL B for a particular value of COL A, V for vertical Vlookup function can be used.

Sub func_vlookup()

Workbooks("workbookname.xls").Activate
Worksheets("Sheet1").Activate

findthis = "cat"
in_range = Range("A1:B3")
rtn_from_col# = 2 ' indicates from which column value is being returned

MsgBox WorksheetFunction.vlookup(findthis, in_range, rtn_from_col#)
'pops up "mouse"

End Sub

Match function can be written similarly. Try it!

Using Excel Functions in VBA - Sum

Sub function_sum()
x = 2
y = 3
some = WorksheetFunction.Sum(x, y)
End Sub

Try to modify code to
1) Display the numbers being added and the sum.
2) Get numbers as user input and sum them up.

Find out how is concatenation done in VBA. It has already been used in previous examples.

Get Last Used Row

Sub get_last_used_row()
' to get the last non-blank row

LastRow1 = Cells(Cells.Rows.Count, "A").End(xlUp).Row
'this is the keyboard equivalent of selecting a range using shift and down arrow
'   Exercise What does "A" signify??

LastRow2 = UsedRange.Rows.Count

MsgBox "LastRow1 " & LastRow1
MsgBox "LastRow2 " & LastRow2

End Sub

Exercise - What is the difference between LastRow1 and LastRow2. Though they might give same results occasionally, the approach to get the last row is different. Find it out!

selcells

Sub selcells()
' this sub shows how to get a cell value
ActiveSheet.Select
cellval = Cells(1, "A")
MsgBox cellval
End Sub

Try writing a sub that copies value of A1 into B1 without use of an intermediate variable.

Select row, column

There are exercises too, today using what you learnt yesterday.


#1
Sub selrow()
ActiveSheet.Select
Range("A1:E1").Select
'exercise - add code to give message when row is selected
End Sub


#2
Sub selcol()
ActiveSheet.Select
Range("A1:A10").Select
'exercise - add code to give message when row is selected
End Sub


Also, if you have time, find out how you can select an entire column. In the above example, we're selecting just a small range.

Msgbox Inputbox

Open excel
Do Alt F11
Paste -

Sub pgmhello()

MsgBox "Hello"
' accept name from user
name1 = InputBox("Name Please")

' concatenate hello and user name
MsgBox "Hello" & name1

End Sub

Click green triangular button or PF5

Try it!