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

    objNewMail.Attachments.Add objMail

    objMail.UnRead = False

    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

Do give your feedback & post your query on form www.ExcelVbaLab.com

Cheers!

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

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

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

Application.DisplayAlerts = 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

        Workbooks.Open xDir$ & sn(i), ReadOnly:=True

        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

Application.DisplayAlerts = 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,

I have a data structure like heading & subheading. Each heading has four subheadings, I want to lookup a data by matching heading & then subheadings, refer data below:

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

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.

Click to Download

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

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

.DisplayAlerts = False

.EnableEvents = False

.AskToUpdateLinks = 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

.DisplayAlerts = True

.EnableEvents = True

.AskToUpdateLinks = 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!!

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 iAnswer As VbMsgBoxResult

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.

'

         If iAnswer = vbYes Then

            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.

'

         ElseIf iAnswer = vbNo Then

          

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

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

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:

Download


Cheers!!

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

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

If shp.TopLeftCell.Address = c.Address Then

Debug.Print shp.Hyperlink.Address

'shp.Hyperlink.Follow NewWindow:=True

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

printThis = PrintThisDoc(0, shp.Hyperlink.Address)

End If

Next shp

Next

End Sub