## Wednesday, May 11, 2016

### Excel VBA Macro Delete all images / drawing objects from sheet in one go

Excel VBA Macro code to Delete all images / drawing objects from sheet in one go:

```Sub DelObjects()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Sheets
On Error Resume Next
sh.DrawingObjects.Delete
sh.OLEObjects.Delete
Next sh
MsgBox "Done!"
End Sub```

Cheers!!

## Sunday, May 1, 2016

### Excel formula to find overlapping dates in columns

Query: I have a range of dates, start date and end date in a single row in below format.

I want to check for overlap for in each row using formula .

Solution:

An overlap exists if any of end date is equal to or lesser than start date for other blocks or any of  start date is equal to or greater than end date for other blocks.

We will compare each end date for criteria 1 & compare each start date criteria 2 as mentioned above using following formula.

=IF(SUMPRODUCT((INDEX((A2:F2)*(MOD(COLUMN(A2:F2),2)<>0),,)<=TRANSPOSE(INDEX((B2:G2)*(MOD(COLUMN(B2:G2),2)=0),,)))*(INDEX((B2:G2)*(MOD(COLUMN(B2:G2),2)=0),,)>=TRANSPOSE(INDEX((A2:F2)*(MOD(COLUMN(A2:F2),2)<>0),,))))>1,"Overlap","No Overlap")

Cheers!!

## Monday, April 25, 2016

### Excel formula : Find Bottom 5 values excluding zero

Query:

I have list of numbers from that i want to extract smallest 5 numbers excluding zero.

Solution:

we can use combination of Small & count if to get the same. Copy below formula and paste down to cell B1 to B5

=SMALL(\$A\$1:\$A\$100,COUNTIF(\$A\$1:\$A\$100,0)+ROW(A1))

Here first count if formula will count for count of numbers equal to zero & will add 1 to it for finding lowest number greater than zero and so on.

Cheers!!

## Wednesday, April 20, 2016

### Excel VBA macro highlight break in attendance / gap in dates

Query: I have downloaded attendance data/log from application employee wise, I want to highlight break days. e.g. if an employee has worked from 1 to 15th , and his next attendance is on 22nd I want to highlight 22nd and similar such data. Also there 5 working days for some employees & 6 working days for others. All Sundays are compulsory holidays & Saturday is extra holidays for those who are working for 5 days.

Data format is as below:

Solution:

Again we will use VBA to get work done, sequence will be :

Read EmpID & Date into array,
Sort array EmpID wise & then date wise using bubble sort method.
Now loop through value in array & check for break.

Code goes here:

```Sub spot_break_rev()

Dim Arr() As Variant
Dim Temp As Variant
Dim Txt As String
Dim i As Long
Dim j As Long
Dim lr As Long
Dim k As Long

lr = Range("A" & Rows.Count).End(xlUp).Row

With Cells.Interior
.Pattern = xlNone
End With

'Allocate value to dynamic array
ReDim Arr(0 To lr - 2)

'Fill the array with the keys from the Dictionary
For i = 0 To lr - 2
Arr(i) = Cells(i + 2, "A") & "^" & Cells(i + 2, "C") & "~" & i + 2
Next i

'Sort the array using the bubble sort method
'Sory by emp code
For i = LBound(Arr) To UBound(Arr) - 1
For j = i + 1 To UBound(Arr)
If Arr(i) > Arr(j) Then
Temp = Arr(j)
Arr(j) = Arr(i)
Arr(i) = Temp
End If
Next j
Next i

'Sort the array using the bubble sort method
'Sory by date if any left out
For i = LBound(Arr) To UBound(Arr) - 1
For j = i + 1 To UBound(Arr)
If Split(Arr(i), "^")(0) = Split(Arr(j), "^")(0) Then
If Split(Arr(i), "^")(0) > Split(Arr(j), "^")(0) Then
Temp = Arr(j)
Arr(j) = Arr(i)
Arr(i) = Temp
End If
End If
Next j
Next i

For i = LBound(Arr) To UBound(Arr) - 1
k = 0
If Split(Arr(i), "^")(0) = Split(Arr(i + 1), "^")(0) Then
If (CDate(Split(Split(Arr(i), "^")(1), "~")(0)) + 1) * 1 <> _
(CDate(Split(Split(Arr(i + 1), "^")(1), "~")(0))) * 1 Then
If Day(CDate(Split(Split(Arr(i + 1), "^")(1), "~")(0))) <> 7 Then
If Cells(Split(Arr(i + 1), "~")(1), "D") <> 6 Then 'chage column no. of days
Cells(Split(Arr(i + 1), "~")(1), "A").EntireRow.Interior.Color = vbYellow
End If
End If
End If
k = k + 1
End If
If k = 0 Then
Cells(Split(Arr(i), "~")(1), "A").EntireRow.Interior.Color = vbYellow
End If
If k = 0 And i = UBound(Arr) - 1 Then
Cells(Split(Arr(i), "~")(1) + 1, "A").EntireRow.Interior.Color = vbYellow
End If

Next i

End Sub

```

Cheers!!

## Sunday, April 17, 2016

### Excel Unique & Difficult formula : Find date when target is achieved (Running total / Cumulative sum for item exceeding target)

Query:

I want a formula for searching date when a total target for particular agent exceeds between select dates. Basically, I have data sheet in which there is a date wise running sales of each agent, there is not a column of running total for each agent in it. I want to know for between any given dates, in a summary sheet for an agent on which date sales has exceeded a given target.

My database is maintained as below

I want a result in the last column from above date

Solution:

Since you are trying to extract result for not standard date range adding running total column will be of no use. Let's construct formula get the desired result:

Step -1 So first we will require to fetch a range which matches an agent name and which is within a date specified,

=INDEX((Data!\$B\$2:\$B\$1000=B8)*(Data!\$A\$2:\$A\$1000>=C8)*(Data!\$A\$2:\$A\$1000<=D8)*ROW(Data!\$C\$2:\$C\$1000),,)

Above formula will give row number of meeting criterion we can get cell address by using formula

=(Data!\$C\$2:\$C\$1000)*( if (Step1_Formula>0,1,0) ),

so revised formula will be :

=(Data!\$C\$2:\$C\$1000)*(IF(INDEX((Data!\$B\$2:\$B\$1000=B8)*(Data!\$A\$2:\$A\$1000>=C8)*(Data!\$A\$2:\$A\$1000<=D8)*ROW(Data!\$C\$2:\$C\$1000),,)>0,1,0))

Here we are checking that if in step 1 formula if a value is zero (i.e. nonmatching item then keep row number to zero else keep this as 1, and multiply this array to data range to get the address of the matching value.

Step -2 Now since we have extracted the daily sales value of required criterion, then we will convert this daily sales value to cumulative sales value. E.G. we have extracted sales values as {100,100,0,0,100} but what we need to match is cumulative sales i.e. {100,200,200,200,300}.

To convert 1st array {100,100,0,0,100} to {100,200,200,200,300} we will use Matrix Multiplication formula, i.e. MMULT.

E.G. You have data in cell A1 to A5 as 1,2,3,4,5 and when you use MMULT formula as follows:

=MMULT(--(ROW(A1:A5)>=TRANSPOSE(ROW(A1:A5))),A1:A5)

Formula will return cumulative sum as {1,3,6,10,15}, i.e. cumulative sum is returned in array. Note MMULT is an array formula so after entering formula instead of pressing enter, use the combination of CSE keys (Control + Shift + Enter keys).

so our formula will look like as below:

=MMULT(--(ROW(Data!\$E\$2:\$E\$1000)>=TRANSPOSE(ROW(Data!\$E\$2:\$E\$1000))),(Data!\$C\$2:\$C\$1000)*(IF(INDEX((Data!\$B\$2:\$B\$1000=B8)*(Data!\$A\$2:\$A\$1000>=C8)*(Data!\$A\$2:\$A\$1000<=D8)*ROW(Data!\$C\$2:\$C\$1000),,)>0,1,0)))

Step -3 As we have received cumulative sum/total we can use LOOKUP formula & get resultant day by assigning array to it by using formula:

=LOOKUP(E8, Step2_Formula, Data!\$A\$2:\$A\$1000)+1

So final formula will look like this:

{=LOOKUP(E8,MMULT(--(ROW(Data!\$E\$2:\$E\$1000)>=TRANSPOSE(ROW(Data!\$E\$2:\$E\$1000))),(Data!\$C\$2:\$C\$1000)*(IF(INDEX((Data!\$B\$2:\$B\$1000=B8)*(Data!\$A\$2:\$A\$1000>=C8)*(Data!\$A\$2:\$A\$1000<=D8)*ROW(Data!\$C\$2:\$C\$1000),,)>0,1,0))),Data!\$A\$2:\$A\$1000)+1}

Enter above formula as an array to get the desired result.

Cheers!!

## Wednesday, April 13, 2016

### Excel Pivot table - Conditional formatting pivot table & maintaining format after filtering and un filtering data

Query: I have a pivot table and I want to have the format apply to any cell in the data area, regardless of the configuration of the column and row fields. I want the formatting to fit whatever the table displays and also same to get refreshed whenever data is refreshed. I tried applying it but as soon as data is filtered out conditional formatting gets lost.

Solution: You can follow steps as below:

Step 1 - Select whole  data area,
Step 2 - click on Conditional Formatting on the Home tab of the Ribbon and choose the conditional format you want to apply.
Step 3 - Click on rectangle box at the right end corner,
Step 4 - Select the last option from radio button,

You can also refer below image

Post your query and feedback on ExcelVbaLab.com

Cheers!!

## Tuesday, April 12, 2016

### Excel VBA Macro to compare employee data head wise between multiple sheet and give out to separate sheet

Query: Hi I have employee master data in two or sometimes three or more sheets, I want to match data in all sheets and get the comparison in new sheets, where macro to check head wise employee wise amount and highlight if miss match.

Ans:

Since there are multiple sheets to compare, we need to loop through all sheets & take unique employee number from all sheets, and similarly extract unique headers from all sheets.

Once we have extracted the same we can generate the ouput in new sheet where we can pull employee details and corresponding head wise amount from different sheet, then we can match amount in next column and highlight the same.

Code goes here:

```Option Explicit
Sub Generate_Diff_V2()
Dim key As Variant
Dim cell As Range, cell2 As Range
Dim wb As Workbook
Dim i As Integer, j As Integer
Dim dict As Object, dict2 As Object
Dim cell3 As Range
Set wb = ThisWorkbook
Dim app

Set app = Application.WorksheetFunction
Set dict = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")

Application.ScreenUpdating = False
dict.RemoveAll
dict2.RemoveAll

For i = 1 To wb.Worksheets.Count
If Sheets(i).Name <> "Output" Then

Sheets(i).Select
For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
If Not dict.exists(Val(cell)) Then
End If
Next

For Each cell In Range(Range("C1"), Cells(1, Range("A1").End(xlToRight).Column))
If Not dict2.exists(cell.Value) Then
End If
Next

End If

Next i

Sheets("Output").Select
Cells.Clear
Cells(3, 1).Resize(dict.Count) = Application.Transpose(dict.Keys)

For Each cell3 In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
cell3.Offset(0, 1).Value = dict(Val(cell3))
Next cell3

Dim k As Integer
Dim rr As Long, cc As Long

k = 2
Cells(2, 1).Value = "ID"
Cells(2, 2).Value = "Name"

For Each key In dict2.Keys
For i = 1 To Worksheets.Count
If Sheets(i).Name <> "Output" Then

Cells(1, k + 1).Value = key
Cells(2, k + 1).Value = Sheets(i).Name

On Error Resume Next
cc = 0
cc = Sheets(i).Range("A1:ZZ1").Find(key, LookIn:=xlValues).Column

For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
On Error Resume Next
rr = 0
rr = Sheets(i).Range("A1:A100000").Find(cell.Value, LookIn:=xlValues).Row
If rr <> 0 And cc <> 0 Then
cell.Offset(0, k).Value = Sheets(i).Cells(rr, cc).Value
Else
cell.Offset(0, k).Value = 0
End If
Next cell

k = Range("ZZ3").End(xlToLeft).Column  'k + 6

End If
Next i

Cells(2, k + 1).Value = "Diff"
For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
'For j = 1 To Worksheets.Count - 1 'dict2.Count
'cell.Offset(0, k).Value = cell.Offset(0, k).Value - cell.Offset(0, k - j).Value
'Next j
j = Worksheets.Count - 1
cell.Offset(0, k).Value = app.Max(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1))) _
= app.Min(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1)))
If Not cell.Offset(0, k).Value Then
cell.Offset(0, k).Interior.Color = vbRed
End If
Next cell
k = Range("ZZ3").End(xlToLeft).Column + 1 'k + 6

Next key

Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub
```

Cheers!!

## Friday, April 8, 2016

### Excel formula to find 1st 2nd (second) 3rd (third) to Nth occurrence in range and match multiple conditions through different columns

Query : I have database containing many columns, i have different tab/sheet for report sheet, in that I have to match values from two columns and extract matching values, problem is that my database there are same values in all two columns, so i want to match & extract 1st instance for 1st case, 2nd instance for second case and so on.

Data is in sheet in below format:

I want report in below format:

Solution: We can use an array formula to match multiple conditions & extract values, but I always try to avoid array formula since I believe it is heavy on sheet when it contains large. This formula is unique since I have tried using Large() function & used index to receive an array value in single column.

I have use following formula:

INDEX(ROW(DATA!\$A\$2:\$A\$19)*(DATA!\$B\$2:\$B\$19=A2)*(DATA!\$A\$2:\$A\$19=B2),,1),
SUMPRODUCT((\$A\$2:\$A\$7=A2)*(\$B\$2:\$B\$7=B2))-SUMPRODUCT((\$A\$2:A2=A2)*(\$B\$2:B2=B2))+1),
COLUMN(D1),1,1,"DATA"))

Step 1: Get row number for matching condition usinh Index Formula:

INDEX(ROW(DATA!\$A\$2:\$A\$19)*(DATA!\$B\$2:\$B\$19=A2)*(DATA!\$A\$2:\$A\$19=B2),,1)

Step 2: To handle repeated values; we need to first fiind total matching values form that total count we will deduct instance of repetation at particular row, this will give us largest matching value for specific cell. Eg.In given report XYZ is repeated 3 times, but for finding value in cell C1 we will find third largest value, for finding value in cell C2 we will find second largest value & for finding value in cell C3 we will find first largest value. This can be arrived by using:

SUMPRODUCT((\$A\$2:\$A\$7=A2)*(\$B\$2:\$B\$7=B2))-SUMPRODUCT((\$A\$2:A2=A2)*(\$B\$2:B2=B2))+1)

Step3: If we put array result of step1 & result of step 2 in function Large() we will get row number of matching value, so formula will be :

=LARGE(INDEX(ROW(DATA!\$A\$2:\$A\$19)*(DATA!\$B\$2:\$B\$19=A2)*(DATA!\$A\$2:\$A\$19=B2),,1), SUMPRODUCT((\$A\$2:\$A\$7=A2)*(\$B\$2:\$B\$7=B2))-SUMPRODUCT((\$A\$2:A2=A2)*(\$B\$2:B2=B2))+1)

Step 4: Using Address formula to convert row number to cell refferrence (address) of destination cell.

Here we used COLUMN(D1) because required result in column D.

Step 5: Using Indirect() function to converer cell address in  Step 4 to required result.

Cheers!!

## Monday, April 4, 2016

### Excel VBA File Upload & Download Manager / File copy paste from one location to another

If you have shared folder without control of who is a uploading & downloading (copying) file, there a simple solution to it. Through this file a manager you can keep a store of your shared folder.

In this macro i have kept C:\temp as default folder which you can change as per your choice, Run macro & select option either upload & download.

When you select download you will be asked to C:\temp folder & you can select file to be download, select file & after that you will be prompted for destination folder where you want to downalod/copy file. Enter file description if any & you are done.

Similarly, for uploading a file you will be prompted to select a file to be uploaded to default folder, select file & file will be copied/uploaded to a default folder.

Give Feedback & Recommendation

## Tuesday, March 29, 2016

### Outlook VBA Macro to group unread email with subject containing Excel & forward all email as attachment to specific email ID

Query: I want to automate incoming emails on the basis of its subject, if this contains word excel I want to attach all such email to new email as a mail item & forward it to particular email ID.

Solution:

We can create loop for all unread email in outlook & check whether it is unread & contains word Excel, and if contains then add email item as an attachment & forward to defined recepient.

```Option Explicit

Sub ConsolEmail()

Dim objMailItems As Items

Dim objMail As Object

Dim ns As NameSpace

Dim mFound As Boolean

Set ns = Application.GetNamespace("MAPI")

Set objMailItems = ns.GetDefaultFolder(olFolderInbox).Items

'Assign the email address to forward items to

Dim msgList As String

msgList = "vba@vabs.in"

'Assign Subject

Dim msgSub As String

msgSub = "Excel"

mFound = False

'Create new email

Dim objNewMail As Object

Set objNewMail = Application.CreateItem(olMailItem)

'Forward each item as attachment

For Each objMail In objMailItems

'Debug.Print objMail.Subject

If objMail.UnRead = True And _

InStr(1, objMail.Subject, msgSub, vbTextCompare) > 1 Then

mFound = True

End If

Next

If mFound Then

objNewMail.To = msgList

objNewMail.Subject = "Group email for " & msgSub

'objNewMail.Save

objNewMail.Display

'objNewMail.Send ' untag this line for sending email instead of displaying

End If

MsgBox "One operation completed"

Set objMail = Nothing

Set objMailItems = Nothing

Set objNewMail = Nothing

End Sub

```

Cheers!

#Tag : #OUTLOOK #VBA #MACRO #TO #GROUP #UNREAD #EMAIL #WITH #SUBJECT #CONTAINING #EXCEL & #FORWARD #ALL #EMAIL #AS #ATTACHMENT #TO #SPECIFIC #EMAIL #ID

## Monday, March 28, 2016

### Excel formula to get total of/sum of all digits(number) in a cell

Query: I have got numbers in cell, i want to find total of all digits (number) in a particular cell.

e.g. If in cell A1 there is number 1234, then i want total/sum of 1+2+3+4=10 in next cell.

Answer: We can achieve this result using SUMPRODUCT formula,

formula is =SUMPRODUCT(--MID(A1,ROW(INDIRECT("1:" & LEN(A1))),1))

Cheers!!

tag: #EXCEL #FOORMULA  #total #of/sum of all #digits(number) in a #cell

## Friday, March 25, 2016

### Excel VBA Macro to Import sheet from all file in folder and then merge first two columns in to master sheet

Hi Every one.

It is big pain for MIS guys to import data from many files to the master file and manipulate the same. Below macro will import all Only Active sheet from each file into the master workbook, after impoting sheets, it will copy first two columns and keep last 10 character from it.

```Option Explicit

Sub Merge_All_Excel()

Application.ScreenUpdating = False

Dim sn(9999) As String

Dim xDir\$, fName As String

Dim sheetname As String

Dim master As Workbook, import As Worksheet, file2 As Workbook

Dim r As Long, i As Long

Dim xt As String

Dim lr As Long

Set master = ThisWorkbook

With Application.FileDialog(msoFileDialogFolderPicker)

.InitialFileName = Application.ThisWorkbook.Path & "\"

.Title = "Please select a folder containing files"

.Show

If .SelectedItems.Count <> 0 Then

xDir\$ = .SelectedItems(1) & "\"

End If

End With

fName = Dir(xDir\$)

r = 1

Do While Len(fName) > 0

If UCase(Split(fName, ".")(UBound(Split(fName, ".")))) = "CSV" Or _

Left(UCase(Split(fName, ".")(UBound(Split(fName, ".")))), 2) = "XL" Then

sn(r) = fName

r = r + 1

End If

fName = Dir

Loop

On Error Resume Next

For i = 1 To r - 1

Set file2 = ActiveWorkbook

Set import = file2.ActiveSheet

import.Copy After:=master.Sheets(master.Sheets.Count)

file2.Close False

master.Sheets(Sheets.Count).Activate

xt = Split(sn(i), ".")(UBound(Split(sn(i), ".")))

sheetname = Replace(sn(i), "." & xt, "")

master.ActiveSheet.Name = sheetname

Next i

Dim shCount As Integer

Dim col As Integer

Dim sh As Worksheet

Dim dRng As Range

Dim cell As Range

Dim LastCell As Range

Dim rng2 As Range

Set sh = Sheets("MASTER")

sh.Activate

sh.Cells.Clear

shCount = Sheets.Count

col = 1

For i = 1 To shCount

If Sheets(i).Name <> "MASTER" Then

Sheets(i).Activate

Set dRng = sh.Cells(1, col)

dRng.Resize(1, 2).Value = Sheets(i).Name

lr = Cells.Find(What:="*", SearchOrder:=xlRows, _

SearchDirection:=xlPrevious, LookIn:=xlValues).Row

Set dRng = sh.Cells(2, col)

Sheets(i).Range("A1:B" & lr).Copy

sh.Select

dRng.PasteSpecial xlPasteValues

col = col + 2

End If

Next

sh.Activate

Application.CutCopyMode = False

Cells.Columns.AutoFit

Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row, Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

Set rng2 = Range(Range("A3"), LastCell)

For Each cell In rng2

If cell.Value <> "" Then

cell.Value = Right(cell.Value, 10)

End If

Next cell

Cells.Columns.AutoFit

Application.ScreenUpdating = True

MsgBox "Done", Title:="www.ExcelVbaLab.Com"

Range("A1").Select

End Sub

```

Do write your feedback & post your excel VBA macro related query on www.ExcelVbaLab.Com

Cheers!!

Tags: #Excel #VBA #Macro to #Import #sheet #from all #files in #folder and then #merge #first two columns into #master #sheet

### Excel Formula double lookup, match heading & sub heading and lookup data from main table

Hi,

Data is like below:

I want output in below format:

Solution:

First we need to match heading & get location of heading & after that we can create specific range related to heading for searching & apply Hlookup formula in that ramge to get result.

Formula 1 : =HLOOKUP(B\$7,OFFSET(\$A\$1,2,MATCH(\$A8,\$A\$1:\$AB\$1,0)-1,2,4),2,0)

Formula 2: =INDEX(\$A\$1:\$AB\$4,4,MATCH(\$A8,\$A\$1:\$AB\$1,0))

Formula 1 is though complecated but gives result in case of there is jumble or interchange in sub headings.

Comment or write to us on forum for clarifications or to post your querries www.ExcelVbaLab.com

Cheers!!

Tags: #Excel #Formula #double #lookup, #match #heading & #subheading and #lookup #data #from #main #table #to #Sub #Table

## Wednesday, March 16, 2016

### Multi column combo box.

Multi column combo box..

Have you ever come across situation wherein you want to show multiple items in combo box with description, but on selection you want to restrict it to only 1st item..

So we will have different view item in combo box & different result value.

See attached file for such example.

Cheers!!

### Excel VBA Macro to copy data from two sheets to third sheet

Query: I want to copy data from two two sheets to third sheet, I have sheet 1 & sheet 2 having multiple columns & rows, some columns in both the sheet have same header, i want to copy few of them to third sheet. So match haeding in sheet 1  copy all data till last row and paste it to last sheet, same for sheet2. Copy data for all column header in last sheet.

Solution:
Make sure haeader in all sheet is similar & we can make macro to search through header in sheet 1/Sheet 2 & if header matches copy data from sheet 1 & paste it to last sheet.

Use below code:
```Option Explicit

Sub copy_data_from _two_sheets_to_Summary_sheet()

Dim Rng As Range, c As Range

Dim sCell As Range

Dim rSize As Long

Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet

Set sh1 = Sheets("File 1")

Set sh2 = Sheets("File 2")

Set sh3 = ThisWorkbook.ActiveSheet

sh3.[A2].Resize([A2].End(xlDown).Row - 1, 1).EntireRow.Clear

Set Rng = sh3.Range([A1], [A1].End(xlToRight))

For Each c In Rng

'Copy data from Sheet 1

Set sCell = sh1.Range("1:1").Find(What:=c.Value, LookIn:=xlValues)

If Not sCell Is Nothing Then

rSize = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count

If c.Offset(1, 0).Value <> "" Then

c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

Else

c.Offset(1, 0).Resize(rSize, 1).Value = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

End If

End If

'Copy data from Sheet 2

Set sCell = sh2.Range("1:1").Find(What:=c.Value, LookIn:=xlValues)

If Not sCell Is Nothing Then

rSize = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count

If c.Offset(1, 0).Value <> "" Then

c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

Else

c.Offset(1, 0).Resize(rSize, 1).Value = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

End If

End If

Next

MsgBox "Done"

End Sub

```

Cheers!!

## Tuesday, March 15, 2016

### Excel VBA Macro Match / Compare two sheets and list out distinct values of both in new sheets

Query:

I have data in sheet1 & similar data in sheet2, however, few of rows cell data is changed, I want to bring all extra data from both the sheet to new sheet with row number so that i can check & correct them one by one.

Solution:

I assume that a number of rows are same & each row has index number in acolumn then using below macro you can search for distinct values in both the sheet & bring them to a new sheet. Download sample file from below:

Click to Downlod

```Option Explicit

Sub Compare_List_Diff()

Dim arrM, d As Object, rngM As Range

Dim arrT, d2 As Object, rngT As Range

Dim r As Integer

Dim wsM As Worksheet, wsT As Worksheet, wsR As Worksheet

Dim iRW As Integer, iCL As Integer

Dim LastCell As Range, LastCell2 As Range, LastCell3 As Range

Dim wsMlr As Integer, wsMlc As Integer

Dim wsTlr As Integer, wsTlc As Integer

Set d = CreateObject("Scripting.Dictionary")

Set d2 = CreateObject("Scripting.Dictionary")

Set wsM = Worksheets("Sheet1")

Set wsT = Worksheets("Sheet2")

Set wsR = Worksheets("Diff")

With Application

.ScreenUpdating = False

.EnableEvents = False

End With

'get last row of Main

wsM.Select

Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _

SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _

Cells.Find(What:="*", SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

wsMlr = LastCell.Row

wsMlc = LastCell.Column

wsT.Select

Set LastCell2 = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _

SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _

Cells.Find(What:="*", SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

wsTlr = LastCell2.Row

wsTlc = LastCell2.Column

wsR.Select

Set LastCell3 = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _

SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _

Cells.Find(What:="*", SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

wsR.Range("2:" & LastCell3.Row).Clear

For iRW = 2 To wsTlr

'trf main sheet row data to arr and store in dict

Set rngM = wsM.Range(wsM.Cells(iRW, 2), wsM.Cells(iRW, wsMlc))

arrM = Application.Transpose(rngM)

'arr = Application.Transpose(wsM.Range(wsM.Cells(iRW, 2), wsM.Cells(iRW, wsMlc)))

For r = 1 To UBound(arrM, 1)

If arrM(r, 1) <> "" Then

d(arrM(r, 1)) = 1

End If

Next r

'trf second sheet row data to range and then to array

wsT.Select

Set rngT = wsT.Range(wsT.Cells(iRW, 2), wsT.Cells(iRW, wsTlc))

arrT = Application.Transpose(rngT.Value)  'values from range to array

For r = 1 To UBound(arrT, 1)

If arrT(r, 1) <> "" Then

d2(arrT(r, 1)) = 1

End If

Next r

'check values in array agst dict

'Erase arrN()

wsR.Cells(iRW, 1).Value = wsT.Cells(iRW, 1).Value

wsR.Cells(iRW, 2).Value = "Row " & iRW

For r = 1 To UBound(arrT, 1)

If Not d.exists(arrT(r, 1)) Then

'arrN(r, 1) = arrV(r, 1)

''wsR.Cells(iRW, r + 1).Value = arrT(r, 1)

wsR.Cells(iRW, "IV").End(xlToLeft).Offset(0, 1).Value = arrT(r, 1)

End If

Next r

For r = 1 To UBound(arrM, 1)

If Not d2.exists(arrM(r, 1)) Then

'arrN(r, 1) = arrV(r, 1)

''wsR.Cells(iRW, r + 1).Value = arrM(r, 1)

wsR.Cells(iRW, "IV").End(xlToLeft).Offset(0, 1).Value = arrM(r, 1)

End If

Next r

Next iRW

wsR.Select

With Application

.ScreenUpdating = True

.EnableEvents = True

End With

MsgBox "Done"

End Sub

```

Thanks for reading give feedback and if you want to customise need, post your query on Group www.ExcelVbaLab.Com

Cheers!!

## Monday, March 14, 2016

### Excel VBA Macro to sort sheet having Alpha numeric name

Query: I want to sort sheet in Ascending or Descending order, please not it has Alpha numeric name so I want sort it in serial order e.g. A1,A2,A3,A11,A12 and not A1,A11,A12,A2,A3

Solution: when comes to sorting 1, 11 & 111 are considered as same picture character resulting into sorting sheet incorrectly, try below code to get desired results:

```Sub Sort_Active_Book_AlphaNum()

Dim i As Integer

Dim j As Integer

Dim a As Integer, b As Integer, Sn1 As String, Sn2 As String

Dim c As String

'

' Prompt the user as which direction they wish to

' sort the worksheets.

'

iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _

& "Clicking No will sort in Descending Order", _

vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")

For i = 1 To Sheets.Count

For j = 1 To Sheets.Count - 1 'Sheets.Count - 1

'

' If the answer is Yes, then sort in ascending order.

'

Sn1 = "": Sn2 = ""

For a = 1 To Len(Sheets(j).Name)

If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then

Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)

End If

Next a

For b = 1 To Len(Sheets(j + 1).Name)

If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then

Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)

End If

Next b

If a <> 0 Then

If Val(Sn1) > Val(Sn2) Then

Sheets(j).Move After:=Sheets(j + 1)

End If

Else

If UCase\$(Sheets(j).Name) > UCase\$(Sheets(j + 1).Name) Then

Sheets(j).Move After:=Sheets(j + 1)

End If

End If

'

' If the answer is No, then sort in descending order.

'

Sn1 = "": Sn2 = ""

For a = 1 To Len(Sheets(j).Name)

If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then

Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)

End If

Next a

For b = 1 To Len(Sheets(j + 1).Name)

If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then

Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)

End If

Next b

If a <> 0 Then

If Val(Sn1) < Val(Sn2) Then

Sheets(j).Move After:=Sheets(j + 1)

End If

Else

If UCase\$(Sheets(j).Name) < UCase\$(Sheets(j + 1).Name) Then

Sheets(j).Move After:=Sheets(j + 1)

End If

End If

End If

Next j

Next i

End Sub

```

Cheers!!

## Friday, March 11, 2016

### Macro help required for creating multiple sheet from filtered table & sort alphanumeric sheet name

<data:blog.title/> <data:blog.pageName/>
Query: I have a data in sheet1 & I want to create multiple sheets with name as column A,

Also, I want to repeat header & formats & want to have all sheets name to be sorted alphabetically, please not that sheet name could be alphanumeric so care to be taken accordingly.

Solution:

Refer attached sheet:

Cheers!!

## Wednesday, March 9, 2016

### Copy visible data from filtered range of all sheets to summary sheet, matching heading

Query: I have sales data in various sheets (about 100 plus columns & a million rows of data in it) also   data is filtered in it.

I wanted to copy these filtered data to summary sheet, but only a few columns (I have all those columns heading in summary sheet)

Solution through macro:

```Option Explicit
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim dest As Range
Dim lDestRow As Long
Dim i As Integer

Sheets("Base Sheet").Select
i = 0
Set Rng = Range([D1], [D1].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
Set dest = c.End(xlDown).Offset(1, 0)
If i = 0 Then
lDestRow = dest.Row
End If

If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If

Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
dest.Select
ActiveSheet.Paste
Else
Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set dest = c.Offset(1, 0)

If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If

dest.Select
ActiveSheet.Paste
End If
i = i + 1
Next
End Sub
```
Cheers!!

## Thursday, March 3, 2016

### Print documents from excel through hyperlink assigned to shape or image

Hi, Let's see how you can print pdf or doc file from excel. Nowadays on excel dashboard we seldom give external link to documents through inset image in cells. When we click on an image in a cell we are directed to the document attached to it, and we can view & print that document after it. However, situation would be different when you are asked to print all such hyperlink docs and there are n number of such cells. So lets create a macro to deal with situation, first you need  to set a default printer, then select range containg cells with a image & run below macro

```Option Explicit

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _

ByVal hwnd As Long, _

ByVal lpOperation As String, _

ByVal lpFile As String, _

ByVal lpParameters As String, _

ByVal lpDirectory As String, _

ByVal nShowCmd As Long) As Long

Public Function PrintThisDoc(formname As Long, FileName As String)

On Error Resume Next

Dim X As Long

X = ShellExecute(formname, "Print", FileName, 0&, 0&, 3)

End Function

Sub print_hyp_doc()

Dim c As Range, rng As Range

Dim shp As Shape

Dim printThis

Set rng = Selection.SpecialCells(xlCellTypeVisible)

On Error Resume Next

For Each c In rng

For Each shp In ActiveSheet.Shapes

'printThis = PrintThisDoc(0, strDir & "\" & strFile)

End If

Next shp

Next

End Sub

```

## Thursday, February 25, 2016

### Outlook VBA macro to auto save an incoming email to local folder based on employee code in subject

My HR department receives hundreds of email daily with employee code in subject line they wanted to save all email to local drive having employee code so that any one can access email offline without providing mail access to whole team..

Their requirement was to read subject line of each email & check for employee code and save email so received employee folder in local drive with same subject line. If there is no folder then new folder to be created automatic, all employee code is like VB12345 & all email to save in C:\EmpPersonal\.

Copy and paste below code in outlook in ThisOutlookSession module:

```Public WithEvents olItems As Outlook.Items

Private Sub Application_Startup()

Dim olApp As Outlook.Application

Dim objNS As Outlook.NameSpace

Set olApp = Outlook.Application

Set objNS = olApp.GetNamespace("MAPI")

Set olItems = objNS.GetDefaultFolder(olFolderInbox).Items

End Sub

Private Sub olItems_ItemAdd(ByVal Item As Object)

On Error GoTo ErrorHandler

Dim msg As Outlook.MailItem

Dim endOfSubject As String

Dim destFolder As String

Dim myCode As String

Dim sName As String

Dim regEx As Object

Dim matches

sName = Item.Subject

ReplaceCharsForFileName sName, "_"

If TypeName(Item) = "MailItem" Then

Set msg = Item

' check if subject field contains CODE

Set regEx = CreateObject("VBScript.RegExp")

With regEx

.Pattern = "\w+\d{5}"

.IgnoreCase = True

.Global = True

End With

If regEx.Test(Item.Subject) Then

Set matches = regEx.Execute(Item.Subject)

myCode = matches(0)

Else

Exit Sub

End If

destFolder = "C:/EmpPersonal/"

destFolder = destFolder & myCode

' if subfolder doesn't exist, create it

If Dir(destFolder, vbDirectory) = "" Then

MkDir destFolder

End If

' Copy msg to local folder

Item.SaveAs destFolder & "/" & sName & ".msg", olMSG

End If

ProgramExit:

Exit Sub

ErrorHandler:

MsgBox Err.Number & " - " & Err.Description

Resume ProgramExit

End Sub

Private Sub ReplaceCharsForFileName(sName As String, _

sChr As String _

)

sName = Replace(sName, "/", sChr)

sName = Replace(sName, "\", sChr)

sName = Replace(sName, ":", sChr)

sName = Replace(sName, "?", sChr)

sName = Replace(sName, Chr(34), sChr)

sName = Replace(sName, "<", sChr)

sName = Replace(sName, ">", sChr)

sName = Replace(sName, "|", sChr)

End Sub

```

Do post your feedback on this.....

Cheers!!

## Monday, January 25, 2016

### Excel VBA Macro to Send all selected draft email to sender one by one automatically from Outlook

Hi

Many of us have an application to create draft mailers to send it to customers to vendors after reviewing, in case it is few of tens then you can do it manually. How about it is tons or thousands ?

Opening draft email one by one & pressing send button is cumbersome.

Here you go a macro which is designed to work email stored in outlook draft folders. You need to select emails which you want to send & run macro. Macro will loop through emails one by one & sends it to user specified in to filed. If no one is specified to field email will be ignored.

Do let me know if you liked it or not, you can write your queries to ExcelVbaLab@googlegroup.com

Cheers!!

## Saturday, January 23, 2016

### Macro of the day : Create dynamic Named Ranges using Macro

Hi All,

Working on dashboards & requires you to create defined name with huge data list, tired of creating names & updating it manually..

Here is simple solution using macro, what you need to do is..

1 - Enter data in main sheet to create defines names of your choice

2 - Macro will create unique names for each item in column B of sheet MainData;
3 - As soon as you type data in sheet MainData, names will get auto updated;
4 - To Delete all names & rebuilt name list click one of the above button;

For any query write back to us on ExcelVbaLab@googlegroups.com

Cheers!!

## Thursday, January 21, 2016

### Use excel to search image on google and insert link of first image found

Hi,

Making project where you need to download tens of hundreds of images from web & tired of googling around..Here comes the solution using Excel VBA Macro.

In column A insert name of objects to be download & in Column B you will get URL of Image & in Column C you will get Image of the same size of your cell.

Source Code:
```'Requires additional references to Microsoft Internet Control

Public Function URLDecode(url\$) As String
With CreateObject("ScriptControl")
.Language = "JavaScript"
URLDecode = .Eval("unescape(""" & url & """)")
End With
End Function

Public Sub Fetch_Image()

Dim IE As InternetExplorer

Dim HTMLdoc As HTMLDocument

Dim imgElements As IHTMLElementCollection

Dim imgElement As HTMLImg

Dim aElement As HTMLAnchorElement

Dim n As Integer, i As Integer

Dim url As String, url2 As String, furl as string

Dim m, lastRow As Long

lastRow = Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To lastRow

url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&source=lnms&tbm=isch&sa=X&rnd=1"

Set IE = New InternetExplorer

With IE

.Visible = False

.navigate url

Do Until .readyState = 4: DoEvents: Loop

'Do Until IE.document.readyState = "complete": DoEvents: Loop

Set HTMLdoc = .document

Set imgElements = HTMLdoc.getElementsByTagName("IMG")

n = 1

For Each imgElement In imgElements

If InStr(imgElement.src, sImageSearchString) Then

If imgElement.ParentNode.nodeName = "A" Then

Set aElement = imgElement.ParentNode

If n = 2 Then

url2 = aElement.href

url3 = imgElement.src

GoTo done:

End If

n = n + 1

End If

End If

Next

done:

furl = InStrRev(url2, "&imgrefurl=", -1)

furl = Mid(url2, 40, furl - 40)

furl = URLDecode(furl)

Cells(i, 2) = furl

Set m = ActiveSheet.Pictures.Insert(furl)

With Cells(i, 3)

t = .Top

l = .Left

w = .Width

h = .Height

End With

With m

.Top = t

.Left = l

.ShapeRange.Width = w

.ShapeRange.Height = h

End With

IE.Quit

Set IE = Nothing

End With

Next

MsgBox "Done!!"

End Sub

```

Cheers!!