write at exceltoexplore@gmail.com : Report Automation|Dashboard in Excel| Provide Excel consulting through macro (VBA) automation |Financial Modeling | Ethical Hacking

Wednesday, 16 November 2011

Find Financial Year- with Formula and Vba


To find out financial year from given use below formula
Assuming your date in cell B3

=IF(MONTH(A3)<4,YEAR(A3)-1&"-"&RIGHT(YEAR(A3),2),YEAR(A3)&"-"&RIGHT(YEAR(A3)+1,2))

OR

=RIGHT(YEAR(A3)-(MONTH(A3)<4),2)&"-"&RIGHT(YEAR(A3)+(MONTH(A3)>3),2)


To increase/decrease days, months, years
Assuming your date in cell A11 you can increase year by 1
'=DATE(YEAR(A11)+1,MONTH(A11),DAY(A11))


To increase/decrease months
Assuming your date in cell A10

'=EOMONTH(A10,12)
This will increase month by 12 from given date


With help of below VBA code you can also find the Financial year
Assuming your dates are in column A

Sub Mtest()

    With Range("A2", Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
       .Formula = "=RIGHT(YEAR(A2)-(MONTH(A2)<4),2)&""-""" _
        & "&RIGHT(YEAR(A2)+(MONTH(A2)>3),2)"
        'use this line if you dont want to keep formula
        '.Value = .Value
    End With
End Sub


Saturday, 1 October 2011

Autofilter multiple worksheets copy data to new workbook and save

This requirement came from excel forum. its like a project work.
change your worksheet name & range accordingly.

This macro autofilter same value across multiple worksheets
Create a new workbook with same worksheets
Copy data to new workbook and save a workbook with name


Sub Mtest()
Dim Rng As Range
Dim ws As Worksheet
Dim shname As String
Dim i As Integer
Dim shn As Long
Dim mx As Variant
Dim x As Integer
Dim LR As Long
Dim sPath As String, sFileName As String
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Set Rng = Sheets("Div").Range("A6:A" & Cells(Rows.Count, 1).End(xlUp).Row)
Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
With ws2
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"), unique:=True
.Name = "Temp"
End With
Sheets("Temp").Columns("A").SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
LR = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LR
Cname = Sheets("Temp").Cells(i, 1)
Set ws2 = Workbooks.Add
mx = Array("Div", "bon", "right")
shn = 1 - LBound(mx)
For x = LBound(mx) To UBound(mx)
Sheets(x + shn).Name = mx(x)
Next x
m = ws2.Name
ThisWorkbook.Activate
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Temp" Then
ws.UsedRange.AutoFilter Field:=1, Criteria1:=Cname
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy
shname = ws.Name
Application.Goto _
    Workbooks(m).Sheets(shname).Cells(1, 1)
ActiveSheet.Paste
ThisWorkbook.Activate
End If
Next ws
ws2.Activate
'Save the new workbook
sPath = ThisWorkbook.Path & "\"
'sPath = "C:\Users\MAHESH\Downloads\Delete\"
sFileName = Cname & ".xls"
Application.DisplayAlerts = False
ws2.SaveAs (sPath & sFileName)
ws2.Close True
ThisWorkbook.Activate
Next i
End Sub

Sunday, 25 September 2011

Combine Multiple worksheets in single worksheet with in workbook

Sub Mtest()
Dim i As Integer
Dim ws As Worksheet
Worksheets(Worksheets.Count).Activate
For i = 1 To Worksheets.Count
'Change sheet name where you want to copy data from all other sheets
If Sheets(i).Name <> "Mainsheet" Then
'change you range here
Sheets(i).Range("A1:A25").Copy Destination:=Sheets("Mainsheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
'OR if header of all sheets are common  & copy used rows
'Sheets(i).UsedRange.Offset(1).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Copy Destination:=Sheets("Mainsheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End Sub

Sunday, 11 September 2011

Extract File name from path & file name

I have already posted how to find the content of folder with vb
if you you want to separate file name from file path & file name then use below formula

suppose your cell A1 contain C:\Users\MAHESH\Downloads\Data sample.xls
=RIGHT(A2,LEN(A2)-FIND("*",SUBSTITUTE(A2,"\","*",LEN(A2)-LEN(SUBSTITUTE(A2,"\","")))))
results will be Data sample.xls



  1.  Find total len of cell   LEN(A1) =41
  2. find Len of cell without "\" using SUBSTITUTE    LEN(SUBSTITUTE(A1,"\","") =37
  3. (1-2) will give u count of number of backslash  "\" i.e (41-37=4)
  4. we got last position of bracket is 4, but don’t know the string position in cell
  5. Find function always find the first instance
  6. Use the SUBSTITUTE function to change the last backslash
  7. FIND("*",SUBSTITUTE(A1,"\","*",4) will give you position of last backslash i.e 26
  8. we are replacing last back slash as * to get the position of last backslash
  9. we have taken 4 (number of backslash) as  instance_num in substitute formula
  10. Use Right function which will give you file name


You can try below DOS command to directory of the folder & sub folder
c:\User> Dir/s/b > F:\file.txt
this will save all the list of file (Directory) in F drive in file.txt you can use file.xls to save output as excel file


Saturday, 10 September 2011

Search String/value in Entire workbook : Return worksheet Name & cell Address

Try :

Sub Mtest()
Dim found As Range
Dim m As String
Dim count As Integer
Dim ws As Worksheet
count = 0
m = InputBox("Enter the Search")
For Each ws In ActiveWorkbook.Worksheets
Set found = ws.Cells.Find(What:=m, LookIn:=xlValues, lookat:=xlWhole)
If Not found Is Nothing Then
count = count + 1
MsgBox found.Worksheet.Name & found.Cells.Address
End If
Next ws
If count = 0 Then MsgBox "No Matches Found"
End Sub

Pivot Table : After double click Change Format of New Sheet to normal

Copy below code in thisworkbook model



Private Sub Workbook_NewSheet(ByVal Sh As Object)
 Dim sht As Worksheet
    Dim oLo As ListObject
    Set sht = ActiveSheet
    For Each oLo In sht.ListObjects
    sht.ListObjects(oLo.Name).TableStyle = ""
    Next
End Sub

Sunday, 21 August 2011

Hide and Unhide Rows based on colours

If you want to hide and unhide rows based on colour you can use below code.
Excel 2007 provide option of filter by colour but below 2007 version you can not.



Sub Mtest()
Dim c As Range
On Error Resume Next
With ActiveSheet
For Each c In .Range("A1:A100")
If c.Interior.ColorIndex <> 6 Then c.EntireRow.Hidden = Not c.EntireRow.Hidden
Next c
End With
On Error GoTo 0
End Sub