admin – ExcelMacroClasses.com

Copy and Attached data file in outlook email from VBA

admin — Thu, 19 Sep 2024 10:52:28 +0000

Option Explicit

Option Explicit

Sub Gen_Email_One_PivotTable()
'This is for 1 tables
'Do not make changes in this program
'From 1 Table only
    Dim pf As PivotField
    Dim pvtname As String
    Dim lRow As Long
    Dim cel As Range
    Dim Pi As PivotItem
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim rng As Range
    Dim emailBody As String
    Dim emailSignature As String
    Dim rowCount As Long
    Dim exportPath As String
    Dim dateStr As String
    Dim fileName As String
    Dim TempWB As Workbook
    Dim TempWS As Worksheet
    Dim msg1 As String
    Dim msg2 As String
    Dim tfolder As String
    Dim region1 As String
    Dim tbl As String

    pvtname = "PivotTable1"
    Set ws = ActiveSheet
    tfolder = Environ("TEMP")
    dateStr = Format(Now, "dd_Mmm_yyyy")

    ' Prepare messages
    msg1 = "Hi Rushikesh, 

 Please find below the detailed sales summary " & _
           "for the " & "" & " region as requested. The report includes the latest figures and trends, highlighting key" & _
           " insights that may be useful for our upcoming discussions.

 Should you require any further information or " & _
           "clarification, feel free to reach out."

    msg2 = "Hi Rushikesh,
Please find the attached excel file for a detailed sales summary " & _
           "for the  region as requested. The report includes the latest figures and trends, highlighting key" & _
           " insights that may be useful for our upcoming discussions. Should you require any further information or " & _
           "clarification, feel free to reach out."

    Application.StatusBar = "Start"

    ' Clear all filters in pivot
    On Error Resume Next
    For Each pf In ws.PivotTables(pvtname).RowFields
        pf.ClearAllFilters
    Next pf
    On Error GoTo 0

    ' Find unique values
    lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    ws.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("A3:A" & lRow), CopyToRange:=ws.Range("L2"), Unique:=True

    lRow = ws.Range("L1048576").End(xlUp).Row - 1
    Set pf = ws.PivotTables(pvtname).PivotFields("Market")

    ' Get default signature
    emailSignature = GetOutlookSignature()

    ' Get Outlook application
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If OutApp Is Nothing Then
        Set OutApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
        
    ' Loop through each unique value
    For Each cel In ws.Range("L3:L" & lRow)
        pf.ClearAllFilters

        ' Set PivotItem visibility
        For Each Pi In pf.PivotItems
            Pi.Visible = (Pi.Name = cel.Value)
        Next Pi

        ' Get the range of data to copy
        lRow = ws.Range("A1048576").End(xlUp).Row
        Set rng = ws.Range("A2:E" & lRow)

        ' Count number of rows
        rowCount = rng.Rows.Count


        ' If data has 20 or fewer rows, send it via email
        If rowCount <= 20 Then
        
        ' Create email body with left alignment
'        emailBody = "" & _
'                "Hello," & _
'                "Please find the filtered data attached." & _
'                ""
                
            'Prepare email body in HTML format
'            tbl = RangeToHTML(rng) 'Replace(RangeToHTML(rng), "align=center", "align=left")
            emailBody = "" & _
                        "" & _
                        Replace(msg1, "", cel.Value) & "
" & Replace(RangeToHTML(rng), "align=center", "align=left") & ""
            
            ' Create and send the email
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .Display ' Use .Send to send directly
                .To = "recipient@example.com" ' Change this to the recipient's email
                .Subject = "Filtered Data: " & cel.Value
                .HTMLBody = emailBody & emailSignature
            End With
'            GoTo endFunction
        ' If data has more than 20 rows, export it to a new Excel file
        Else
            ' Create a new workbook
            Set TempWB = Workbooks.Add
            Set TempWS = TempWB.Sheets(1)

            ' Copy the filtered range to the new workbook
            rng.Copy
            TempWS.Range("A1").PasteSpecial Paste:=xlPasteValues
            TempWS.Range("A1").PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False

            ' Generate the file name and save the new workbook
            fileName = cel.Value & "_" & dateStr & ".xlsx"
            exportPath = tfolder & "\" & fileName
            TempWB.SaveAs fileName:=exportPath, FileFormat:=xlOpenXMLWorkbook
            TempWB.Close SaveChanges:=False

            ' Prepare email with the file attached
            emailBody = "" & _
                        "" & _
                        Replace(msg2, "", cel.Value) & "
" & RangeToHTML(rng) & ""

            ' Create and send the email with attachment
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = "recipient@example.com" ' Change this to the recipient's email
                .Subject = "Filtered Data: " & cel.Value
                .HTMLBody = emailBody & emailSignature
                .Attachments.Add exportPath
                .Display ' Use .Send to send directly
            End With
            
'            GoTo endFunction
        End If

        ' Cleanup
        Set rng = Nothing
        Set TempWB = Nothing
    Next cel

endFunction:
    Application.StatusBar = False
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Sub Gen_Email_TwoPivotTable()
'This is for 2 tables
    Dim pf1 As PivotField
    Dim pf2 As PivotField
    Dim pvtname As String
    Dim lRow As Long
    Dim cel As Range
    Dim Pi As PivotItem
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim emailBody As String
    Dim emailSignature As String
    Dim rowCount As Long
    Dim exportPath As String
    Dim dateStr As String
    Dim fileName As String
    Dim TempWB As Workbook
    Dim TempWS As Worksheet
    Dim msg1 As String
    Dim msg2 As String
    Dim tfolder As String
    Dim region1 As String
    Dim tbl As String
    Dim pvt1 As String
    Dim pvt2 As String
    
  

    ' PivotTable names and sheet names
    pvt1 = "PivotTable1"
    pvt2 = "PivotTable1"
    Set ws1 = Worksheets("Global_Super_Store") ' Adjust to the actual sheet name for PivotTable1
    Set ws2 = Worksheets("Detailed Data") ' Adjust to the actual sheet name for PivotTable2

     ' Prepare messages
    msg1 = "Hi Rushikesh, 

 Please find below the detailed sales summary " & _
           "for the " & "" & " region as requested. The report includes the latest figures and trends, highlighting key" & _
           " insights that may be useful for our upcoming discussions.

 Should you require any further information or " & _
           "clarification, feel free to reach out."
    ' Get Outlook signature
    emailSignature = GetOutlookSignature()

    ' Get Outlook application
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If OutApp Is Nothing Then
        Set OutApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0

    ' Clear all filters in PivotTable1 (ws1)
    On Error Resume Next
    For Each pf1 In ws1.PivotTables(pvt1).RowFields
        pf1.ClearAllFilters
    Next pf1
    On Error GoTo 0

    ' Clear all filters in PivotTable2 (ws2)
    On Error Resume Next
    For Each pf2 In ws2.PivotTables(pvt2).RowFields
        pf2.ClearAllFilters
    Next pf2
      On Error GoTo 0
      
    ws1.Range("L:L").ClearContents
    ' Filter unique values for PivotTable1 (assume both PivotTables share the same region)
    lRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    ws1.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ws1.Range("A3:A" & lRow), CopyToRange:=ws1.Range("L2"), Unique:=True
    'ws1.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws1.Range("L2"), Unique:=True

    lRow = ws1.Range("L1048576").End(xlUp).Row - 1
    Set pf1 = ws1.PivotTables(pvt1).PivotFields("Market")
    Set pf2 = ws2.PivotTables(pvt2).PivotFields("Market")
    dateStr = Format(Now(), "DDMMYYYY_HHMMSS")
    ' Loop through each unique value
    For Each cel In ws1.Range("L3:L" & lRow)
        ' Filter PivotTable1 on ws1
        pf1.ClearAllFilters
        For Each Pi In pf1.PivotItems
            Pi.Visible = (Pi.Name = cel.Value)
        Next Pi

        ' Filter PivotTable2 on ws2 (if needed)
        pf2.ClearAllFilters
        For Each Pi In pf2.PivotItems
            Pi.Visible = (Pi.Name = cel.Value)
        Next Pi

        ' Get range for PivotTable1 (ws1)
        lRow = ws1.Range("A1048576").End(xlUp).Row
        Set rng1 = ws1.Range("A2:E" & lRow)

        ' Get range for PivotTable2 (ws2)
        lRow = ws2.Range("A1048576").End(xlUp).Row
        Set rng2 = ws2.Range("A2:E" & lRow)

        ' Prepare the email body
       

         emailBody = "" & _
                        "" & _
                        Replace(msg1, "", cel.Value) & "
" & Replace(RangeToHTML(rng1), "align=center", "align=left") & ""
            
            
            
            
            ' Create a new workbook
            Set TempWB = Workbooks.Add
            Set TempWS = TempWB.Sheets(1)

            ' Copy the filtered range to the new workbook
            rng2.Copy
            TempWS.Range("A1").PasteSpecial Paste:=xlPasteValues
            TempWS.Range("A1").PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False

            ' Generate the file name and save the new workbook
            fileName = cel.Value & "_" & dateStr & ".xlsx"
            exportPath = "C:\Users\Ajeet Prasad\Downloads\" & fileName
            Application.DisplayAlerts = False
            TempWB.SaveAs fileName:=exportPath, FileFormat:=xlOpenXMLWorkbook
            TempWB.Close SaveChanges:=False
            Application.DisplayAlerts = True
            
            
            ' Prepare email with the file attached
'            emailBody = "" & _
'                        "" & _
'                        Replace(msg1, "", cel.Value) & "
" & RangeToHTML(rng1) & ""

            ' Create and send the email with attachment
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = "recipient@example.com" ' Change this to the recipient's email
                .Subject = "Filtered Data: " & cel.Value
                .HTMLBody = emailBody & emailSignature
                .Attachments.Add exportPath
                .Display ' Use
'                .Send 'to send directly
            End With
            
            
        ' Cleanup
        Set rng1 = Nothing
        Set rng2 = Nothing
    Next cel

endFunction:
    Application.StatusBar = False
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub






Function RangeToHTML(rng As Range) As String
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    ' Copy range to a temporary workbook
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1, 1).PasteSpecial Paste:=8 ' A1
        .Cells(1, 1).PasteSpecial Paste:=xlPasteValues ' A1
        .Cells(1, 1).PasteSpecial Paste:=xlPasteFormats  'A1
        Application.CutCopyMode = False
    End With

    ' Publish the sheet to an HTML file
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        fileName:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    ' Read the HTML file back as a string
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangeToHTML = ts.ReadAll
    ts.Close

    ' Clean up
    TempWB.Close SaveChanges:=False
    Kill TempFile
End Function

' Function to get the default Outlook signature
Function GetOutlookSignature() As String
    Dim fso As Object
    Dim ts As Object
    Dim sigFile As String
    Dim sigPath As String

    sigPath = Environ("appdata") & "\Microsoft\Signatures\"
    sigFile = Dir(sigPath & "*.htm")

    If sigFile <> "" Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.OpenTextFile(sigPath & sigFile, 1, False)
        GetOutlookSignature = ts.ReadAll
        ts.Close
    Else
        GetOutlookSignature = ""
    End If
End Function


Sub SetSensitivityLabelExcel()
    Dim wb As Workbook
    Set wb = ActiveWorkbook

    ' Check if workbook supports sensitivity labels
    If wb.SensitivityLabelPolicy.Count > 0 Then
        ' Assign the first available sensitivity label
        Dim sensitivityLabel As Office.SensitivityLabel
        Set sensitivityLabel = wb.SensitivityLabelPolicy.Labels(1) ' Set to the first label

        ' Apply the label to the workbook
        wb.SensitivityLabelPolicy.ApplyLabel sensitivityLabel

        MsgBox "Label '" & sensitivityLabel.Name & "' applied to workbook."
    Else
        MsgBox "No sensitivity labels available for this workbook."
    End If

    ' Save the workbook
    wb.Save
    MsgBox "Workbook saved with sensitivity label."
End Sub

Sub RetrieveSensitivityLabelInfoExcel()
    Dim wb As Workbook
    Set wb = ActiveWorkbook

    ' Check if the workbook has a sensitivity label
    If Not wb.SensitivityLabel Is Nothing Then
        MsgBox "Current sensitivity label: " & wb.SensitivityLabel.Name
    Else
        MsgBox "No sensitivity label applied to this workbook."
    End If
End Sub
'Combine code and resolve the error.
Public uMsg        As String
Sub CommandButton1_Click()
    Dim OutApp      As Object
    Dim OutMail     As Object
    
    Dim pt          As PivotTable

    Dim pf          As PivotField
    Dim pf2         As PivotField
    Dim pvt         As String
    Dim pvt2        As String
    
    Dim pvtname     As String
    Dim pi          As PivotItem
    
    Dim lRow        As Long
    Dim rowCount    As Long
    Dim cel         As Range
    
    Dim wb          As Workbook
    Dim TempWB      As Workbook
    Dim ws          As Worksheet
    Dim ws2         As Worksheet
    Dim TempWS      As Worksheet
    
    Dim rng         As Range
    Dim rng2        As Range
    Dim selectedCell As Range
    
    Dim emailBody   As String
    Dim emailSignature As String
    
    Dim exportPath  As String
    Dim dateStr     As String
    Dim fileName    As String
    Dim msg1        As String
    Dim msg2        As String
    Dim tfolder     As String
    Dim region1     As String
    Dim tbl         As String

    uMsg = ""
    'Validation
    If optTable1 = False And optTable2 = False Then
        uMsg = "Please Select 1 of the option"
        GoTo endfunction
    End If
    
    ' Prepare messages
    msg1 = ThisWorkbook.Worksheets("Admin").Range("C2").Value
    msg2 = ThisWorkbook.Worksheets("Admin").Range("C3").Value
    
    On Error Resume Next
    ' Prompt user to select a cell using an InputBox
    Set selectedCell = Application.InputBox("Please Select a cell inside a PivotTable", Type:=8)
    ' Check if the selection is valid
    If selectedCell Is Nothing Then
        uMsg = "No cell selected. Exiting."
        GoTo endfunction
    End If
    ' Check if the selected cell is inside a PivotTable
    If selectedCell.PivotTable Is Nothing Then
        uMsg = "The selected cell Is Not inside a PivotTable."
        GoTo endfunction
    End If
    On Error GoTo 0
    
    ' Set references to the PivotTable, Worksheet, and Workbook
    Set pt = selectedCell.PivotTable
    Set ws = pt.Parent
    'Set wb = ws.Parent
    pvtname = pt.Name
    
If optTable2 = True Then
     ' Prompt user to select a cell using an InputBox
    Set selectedCell = Application.InputBox("Please Select a cell inside a PivotTable2", Type:=8)
    ' Check if the selection is valid
    If selectedCell Is Nothing Then
        uMsg = "No cell selected. Exiting."
        GoTo endfunction
    End If
    On Error Resume Next
    ' Check if the selected cell is inside a PivotTable
    If selectedCell.PivotTable Is Nothing Then
        uMsg = "The selected cell Is Not inside a PivotTable."
        GoTo endfunction
    End If
    On Error GoTo 0
End If
    ' Set references to the PivotTable, Worksheet, and Workbook
    Set pt = selectedCell.PivotTable
    Set ws2 = pt.Parent
    pvtname2 = pt.Name
       
    tfolder = Environ("TEMP")
    dateStr = Format(Now(), "DDMMYYYY_HHMMSS")
    'Get default signature
    emailSignature = GetOutlookSignature()
    ' Get Outlook application
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If OutApp Is Nothing Then
        Set OutApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
        
    If optTable1 = True Then
        Application.StatusBar = "Start"
        ' Clear all filters in pivot
        On Error Resume Next
        For Each pf In ws.PivotTables(pvtname).RowFields
            pf.ClearAllFilters
        Next pf
        On Error GoTo 0
        ' Find unique values
        ws.Range("L:L").ClearContents
        
        lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        ws.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ws.Range("A3:A" & lRow), CopyToRange:=ws.Range("L2"), Unique:=True
        
        lRow = ws.Range("L1048576").End(xlUp).Row
        Set pf = ws.PivotTables(pvtname).PivotFields("Market")
        
        ' Loop through each unique value
        For Each cel In ws.Range("L3:L" & lRow)
            pf.ClearAllFilters
            
            ' Set PivotItem visibility
            For Each pi In pf.PivotItems
                pi.Visible = (pi.Name = cel.Value)
            Next pi
            
            ' Get the range of data to copy
            lRow = ws.Range("A1048576").End(xlUp).Row
            Set rng = ws.Range("A2:E" & lRow)
            
            ' Count number of rows
            rowCount = rng.Rows.Count
            ' If data has 20 or fewer rows, send it via email
            If rowCount <= 20 Then
                
                'Prepare email body in HTML format
                emailBody = "" & _
                "" & _
                Replace(msg1, "", cel.Value) & "
" & Replace(RangeToHTML(rng), "align=center", "align=left") & ""
                
                ' Create and send the email
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .Display
                    .to = "recipient@example.com"        ' Change this to the recipient's email
                    .Subject = "Filtered Data: " & cel.Value
                    .HTMLBody = emailBody & emailSignature
                End With
            ' If data has more than 20 rows, export it to a new Excel file
            ElseIf rowCount > 20 Then
                ' Create a new workbook
                Set TempWB = Workbooks.Add
                Set TempWS = TempWB.Sheets(1)
                
                ' Copy the filtered range to the new workbook
                rng.Copy
                TempWS.Range("A1").PasteSpecial Paste:=xlPasteValues
                TempWS.Range("A1").PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False
                
                ' Generate the file name and save the new workbook
                fileName = cel.Value & "_" & dateStr & ".xlsx"
                exportPath = tfolder & "\" & fileName
                TempWB.SaveAs fileName:=exportPath, FileFormat:=xlOpenXMLWorkbook
                TempWB.Close SaveChanges:=False
                
                ' Prepare email with the file attached
                emailBody = "" & _
                "" & _
                Replace(msg2, "", cel.Value) & "
" & RangeToHTML(rng) & ""
                
                ' Create and send the email with attachment
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .to = "recipient@example.com"        ' Change this to the recipient's email
                    .Subject = "Filtered Data: " & cel.Value
                    .HTMLBody = emailBody & emailSignature
                    .Attachments.Add exportPath
                    .Display
                End With
            End If
        Next cel
    ElseIf optTable2 = True Then
        ' Clear all filters in PivotTable1 (ws)
        On Error Resume Next
        For Each pf In ws.PivotTables(pvtname).RowFields
            pf.ClearAllFilters
        Next pf
        On Error GoTo 0
        
        ' Clear all filters in PivotTable2 (ws2)
        On Error Resume Next
        For Each pf2 In ws2.PivotTables(pvtname2).RowFields
            pf2.ClearAllFilters
        Next pf2
        On Error GoTo 0
        
        ws.Range("L:L").ClearContents
        ' Filter unique values for PivotTable1 (assume both PivotTables share the same region)
        lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        ws.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ws.Range("A3:A" & lRow), CopyToRange:=ws.Range("L2"), Unique:=True
        
        lRow = ws.Range("L1048576").End(xlUp).Row - 1
        Set pf = ws.PivotTables(pvtname).PivotFields("Market")
        Set pf2 = ws2.PivotTables(pvtname2).PivotFields("Market")
        
        ' Loop through each unique value
        For Each cel In ws.Range("L3:L" & lRow)
            ' Filter PivotTable1 on ws
            pf.ClearAllFilters
            For Each pi In pf.PivotItems
                pi.Visible = (pi.Name = cel.Value)
            Next pi
            
            ' Filter PivotTable2 on ws2 (if needed)
            pf2.ClearAllFilters
            For Each pi In pf2.PivotItems
                pi.Visible = (pi.Name = cel.Value)
            Next pi
            
            ' Get range for PivotTable1 (ws)
            lRow = ws.Range("A1048576").End(xlUp).Row
            Set rng = ws.Range("A2:E" & lRow)
            
            ' Get range for PivotTable2 (ws2)
            lRow = ws2.Range("A1048576").End(xlUp).Row
            Set rng2 = ws2.Range("A2:E" & lRow)
            
            ' Prepare the email body
            
            emailBody = "" & _
                        "" & _
                        Replace(msg1, "", cel.Value) & "
" & Replace(RangeToHTML(rng), "align=center", "align=left") & ""
            
            ' Create a new workbook
            Set TempWB = Workbooks.Add
            Set TempWS = TempWB.Sheets(1)
            
            ' Copy the filtered range to the new workbook
            rng2.Copy
            TempWS.Range("A1").PasteSpecial Paste:=xlPasteValues
            TempWS.Range("A1").PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
            
            ' Generate the file name and save the new workbook
            fileName = cel.Value & "_" & dateStr & ".xlsx"
            exportPath = myDownloadPath & "\" & fileName
            Application.DisplayAlerts = False
            TempWB.SaveAs fileName:=exportPath, FileFormat:=xlOpenXMLWorkbook
            TempWB.Close SaveChanges:=False
            Application.DisplayAlerts = True
            
            ' Create and send the email with attachment
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .to = "recipient@example.com"        ' Change this to the recipient's email
                .Subject = "Filtered Data: " & cel.Value
                .HTMLBody = emailBody & emailSignature
                .Attachments.Add exportPath
                .Display
            End With
        Next cel
    End If
    
endfunction:
    Application.StatusBar = False
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set TempWB = Nothing
    Set TempWS = Nothing
    Set ws = Nothing
    Set ws2 = Nothing
    Set pf = Nothing
    Set pf2 = Nothing
    Set pi = Nothing
    Set rng = Nothing
    Set rng = Nothing
    Set rng2 = Nothing
    Set pf = Nothing
    Set cel = Nothing
    If uMsg <> "" Then MsgBox uMsg
    'SheetError:
    '    MsgBox "One or both of the sheets were not found. Please check the sheet names.", vbCritical
    
End Sub

laptop

admin — Mon, 26 Aug 2024 17:12:42 +0000

‘Dim HTMLDoc As Object
Dim HTMLDoc As MSHTML.HTMLDocument
Dim currentElement As MSHTML.IHTMLElement
‘Dim HTMLDoc As MSHTML.HTMLDocument
Dim bodyElement As MSHTML.IHTMLElement
Dim iElement As MSHTML.IHTMLElement
Private Sub UserForm_Initialize()
‘ Set the initial URL to Google search
WebBrowser1.Navigate “https://www.google.com/search?q=indian train”
End Sub

Private Sub CommandButton1_Click()
‘ Navigate to the desired web page
‘WebBrowser1.Navigate “https://www.example.com” ‘ Change this to your target URL

' Wait for the page to load completely
Do While WebBrowser1.Busy Or WebBrowser1.ReadyState <> READYSTATE_COMPLETE
    DoEvents
Loop

' Get the HTML document
Dim HTMLDoc As MSHTML.HTMLDocument
Set HTMLDoc = WebBrowser1.Document

' Clear previous results in ListBox
ListBox1.Clear

' Get all elements in the document
Dim allelements As MSHTML.IHTMLElementCollection
Set allelements = HTMLDoc.getElementsByTagName("*") ' * gets all elements

Dim htmlElement As MSHTML.IHTMLElement
For Each htmlElement In allelements
    ' Display element tag name, ID, class, and innerText in the ListBox
    Debug.Print "Tag: " & htmlElement.tagName _
                     & ", ID: " & htmlElement.ID _
                     & ", Class: " & htmlElement.className _
                     & ", Text: " & htmlElement.innerText
Next htmlElement

End Sub

Function eDetail()
Dim i As Long
For i = 0 To iElement.Children.Length – 1
Set currentElement = iElement.Children(i)
Debug.Print “Child ” & i & “: ” & currentElement.tagName & ” (Children count: ” & currentElement.Children.Length & “)”
Next i
End Function

Private Sub CommandButton2_Click()
‘ Navigate to the desired web page
‘WebBrowser1.Navigate “https://www.example.com” ‘ Replace with your target URL

' Wait for the page to load completely
Do While WebBrowser1.Busy Or WebBrowser1.ReadyState <> READYSTATE_COMPLETE
    DoEvents
Loop

' Get the HTML document

Set HTMLDoc = WebBrowser1.Document

' Start by getting the body element

Set bodyElement = HTMLDoc.getElementsByTagName("body")(0)

If bodyElement Is Nothing Then
    MsgBox "Body element not found."
    Exit Sub
End If

' Debug: Print body element
Debug.Print "Body found: " & bodyElement.tagName

' Iterate over all children of the body

‘ For i = 0 To bodyElement.Children.Length – 1
‘ Set currentElement = bodyElement.Children(i)
‘ Debug.Print “Child ” & i & “: ” & currentElement.tagName & ” (Children count: ” & currentElement.Children.Length & “)”
‘ Next i
Set iElement = bodyElement
Call eDetail

' Step 1: /html/body/div[4]
Set currentElement = bodyElement.Children(1)
If currentElement Is Nothing Then
    MsgBox "Step 1: div[4] not found."
    Exit Sub
End If
'Debug.Print "Step 1: " & currentElement.tagName

Set iElement = currentElement
Call eDetail
'/html/body/div[4]/div/div[13]/div[1]/div[2]/div[2]/div/div/div[4]
' Step 2: /div
Set currentElement = currentElement.Children(0)

If currentElement Is Nothing Then
    MsgBox "Step 2: First child div not found."
    Exit Sub
End If

‘ Debug.Print “Step 2: ” & currentElement.tagName
Set iElement = currentElement
Call eDetail

' Step 3: /div[13]
Set currentElement = currentElement.Children(12)
If currentElement Is Nothing Then
    MsgBox "Step 3: div[13] not found."
    Exit Sub
End If
Debug.Print "Step 3: " & currentElement.tagName

' Step 4: /div[1]
Set currentElement = currentElement.Children(0)
If currentElement Is Nothing Then
    MsgBox "Step 4: div[1] not found."
    Exit Sub
End If
Debug.Print "Step 4: " & currentElement.tagName

' Step 5: /div[2]
Set currentElement = currentElement.Children(1)
If currentElement Is Nothing Then
    MsgBox "Step 5: div[2] not found."
    Exit Sub
End If
Debug.Print "Step 5: " & currentElement.tagName

' Step 6: /div[2]
Set currentElement = currentElement.Children(1)
If currentElement Is Nothing Then
    MsgBox "Step 6: div[2] not found."
    Exit Sub
End If
Debug.Print "Step 6: " & currentElement.tagName

' Step 7: /div
Set currentElement = currentElement.Children(0)
If currentElement Is Nothing Then
    MsgBox "Step 7: First child div not found."
    Exit Sub
End If
Debug.Print "Step 7: " & currentElement.tagName

' Step 8: /div
Set currentElement = currentElement.Children(0)
If currentElement Is Nothing Then
    MsgBox "Step 8: First child div not found."
    Exit Sub
End If
Debug.Print "Step 8: " & currentElement.tagName

' Step 9: /div[4]
Set currentElement = currentElement.Children(3)
If currentElement Is Nothing Then
    MsgBox "Step 9: div[4] not found."
    Exit Sub
End If
Debug.Print "Step 9: " & currentElement.tagName

' Display the inner text or HTML of the target element
MsgBox "Found element: " & vbCrLf & currentElement.innerText

End Sub

sample

admin — Mon, 12 Aug 2024 12:10:32 +0000

'Dim HTMLDoc As Object
Dim HTMLDoc As MSHTML.HTMLDocument
Dim currentElement As MSHTML.IHTMLElement
'Dim HTMLDoc As MSHTML.HTMLDocument
Dim bodyElement As MSHTML.IHTMLElement
Dim iElement As MSHTML.IHTMLElement
Private Sub UserForm_Initialize()
    ' Set the initial URL to Google search
    WebBrowser1.Navigate "https://www.google.com/search?q=indian train"
End Sub


Private Sub CommandButton1_Click()
    ' Navigate to the desired web page
    'WebBrowser1.Navigate "https://www.example.com" ' Change this to your target URL
    
    ' Wait for the page to load completely
    Do While WebBrowser1.Busy Or WebBrowser1.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Loop
    
    ' Get the HTML document
    Dim HTMLDoc As MSHTML.HTMLDocument
    Set HTMLDoc = WebBrowser1.Document
    
    ' Clear previous results in ListBox
    ListBox1.Clear
    
    ' Get all elements in the document
    Dim allelements As MSHTML.IHTMLElementCollection
    Set allelements = HTMLDoc.getElementsByTagName("*") ' * gets all elements
    
    Dim htmlElement As MSHTML.IHTMLElement
    For Each htmlElement In allelements
        ' Display element tag name, ID, class, and innerText in the ListBox
        Debug.Print "Tag: " & htmlElement.tagName _
                         & ", ID: " & htmlElement.ID _
                         & ", Class: " & htmlElement.className _
                         & ", Text: " & htmlElement.innerText
    Next htmlElement
End Sub


Function eDetail()
Dim i As Long
For i = 0 To iElement.Children.Length - 1
    Set currentElement = iElement.Children(i)
    Debug.Print "Child " & i & ": " & currentElement.tagName & " (Children count: " & currentElement.Children.Length & ")"
Next i
End Function

Private Sub CommandButton2_Click()
    ' Navigate to the desired web page
    'WebBrowser1.Navigate "https://www.example.com" ' Replace with your target URL
    
    ' Wait for the page to load completely
    Do While WebBrowser1.Busy Or WebBrowser1.ReadyState <> READYSTATE_COMPLETE
        DoEvents
    Loop
    
    ' Get the HTML document

    Set HTMLDoc = WebBrowser1.Document
    
    ' Start by getting the body element

    Set bodyElement = HTMLDoc.getElementsByTagName("body")(0)
    
    If bodyElement Is Nothing Then
        MsgBox "Body element not found."
        Exit Sub
    End If
    
    ' Debug: Print body element
    Debug.Print "Body found: " & bodyElement.tagName
    
    ' Iterate over all children of the body
'    For i = 0 To bodyElement.Children.Length - 1
'        Set currentElement = bodyElement.Children(i)
'        Debug.Print "Child " & i & ": " & currentElement.tagName & " (Children count: " & currentElement.Children.Length & ")"
'    Next i
    Set iElement = bodyElement
    Call eDetail
    
    ' Step 1: /html/body/div[4]
    Set currentElement = bodyElement.Children(1)
    If currentElement Is Nothing Then
        MsgBox "Step 1: div[4] not found."
        Exit Sub
    End If
    'Debug.Print "Step 1: " & currentElement.tagName
    
    Set iElement = currentElement
    Call eDetail
    '/html/body/div[4]/div/div[13]/div[1]/div[2]/div[2]/div/div/div[4]
    ' Step 2: /div
    Set currentElement = currentElement.Children(0)
    
    If currentElement Is Nothing Then
        MsgBox "Step 2: First child div not found."
        Exit Sub
    End If
'    Debug.Print "Step 2: " & currentElement.tagName
    Set iElement = currentElement
    Call eDetail
    
    ' Step 3: /div[13]
    Set currentElement = currentElement.Children(12)
    If currentElement Is Nothing Then
        MsgBox "Step 3: div[13] not found."
        Exit Sub
    End If
    Debug.Print "Step 3: " & currentElement.tagName
    
    ' Step 4: /div[1]
    Set currentElement = currentElement.Children(0)
    If currentElement Is Nothing Then
        MsgBox "Step 4: div[1] not found."
        Exit Sub
    End If
    Debug.Print "Step 4: " & currentElement.tagName
    
    ' Step 5: /div[2]
    Set currentElement = currentElement.Children(1)
    If currentElement Is Nothing Then
        MsgBox "Step 5: div[2] not found."
        Exit Sub
    End If
    Debug.Print "Step 5: " & currentElement.tagName
    
    ' Step 6: /div[2]
    Set currentElement = currentElement.Children(1)
    If currentElement Is Nothing Then
        MsgBox "Step 6: div[2] not found."
        Exit Sub
    End If
    Debug.Print "Step 6: " & currentElement.tagName
    
    ' Step 7: /div
    Set currentElement = currentElement.Children(0)
    If currentElement Is Nothing Then
        MsgBox "Step 7: First child div not found."
        Exit Sub
    End If
    Debug.Print "Step 7: " & currentElement.tagName
    
    ' Step 8: /div
    Set currentElement = currentElement.Children(0)
    If currentElement Is Nothing Then
        MsgBox "Step 8: First child div not found."
        Exit Sub
    End If
    Debug.Print "Step 8: " & currentElement.tagName
    
    ' Step 9: /div[4]
    Set currentElement = currentElement.Children(3)
    If currentElement Is Nothing Then
        MsgBox "Step 9: div[4] not found."
        Exit Sub
    End If
    Debug.Print "Step 9: " & currentElement.tagName
    
    ' Display the inner text or HTML of the target element
    MsgBox "Found element: " & vbCrLf & currentElement.innerText
    
End Sub

VBA with Pivot and Slicer

admin — Sun, 04 Aug 2024 08:18:07 +0000

Sub SelectSlicerItemAndFilterPivotTable()
    Dim ws As Worksheet
    Dim sc As SlicerCache
    Dim si As SlicerItem
    Dim pt As PivotTable
    Dim itemFound As Boolean
    Dim sItem As String
    Dim slicerName As String
    Dim pivotTableName As String
    Dim ptField As Range


    ' Initialize variables
    sItem = "C" ' The item you want to select
    slicerName = "Slicer_Cat" ' The name of the slicer cache
    pivotTableName = "PivotTable1" ' The name of the PivotTable

    ' Set references to worksheet, slicer cache, and PivotTable
    Set ws = ThisWorkbook.Worksheets("Sheet4")
    Set sc = ThisWorkbook.SlicerCaches(slicerName)
    On Error Resume Next
    Set pt = ws.PivotTables(pivotTableName)
    On Error GoTo 0

    ' Check if the PivotTable is connected to the slicer
    If pt Is Nothing Then
        MsgBox "PivotTable '" & pivotTableName & "' not found on worksheet '" & ws.Name & "'.", vbExclamation
        GoTo CleanUp
    End If

    ' Clear previous slicer selections
    sc.ClearAllFilters

    ' Find and select the specific slicer item
    itemFound = False
    For Each si In sc.SlicerItems
        If si.Name = sItem Then
            si.Selected = True
            itemFound = True
        Else
            si.Selected = False
        End If
    Next si

    ' Inform the user if the slicer item was not found
    If Not itemFound Then
        MsgBox "The slicer item '" & sItem & "' was not found.", vbExclamation
    Else
        ' Refresh the PivotTable to apply the filter
        pt.RefreshTable
        
        ' Optional: Output filtered data for verification
        For Each ptField In pt.DataBodyRange.Rows
            Debug.Print ptField.Value
        Next ptField
    End If

CleanUp:
    ' Clear object references
    Set ws = Nothing
    Set sc = Nothing
    Set pt = Nothing
    Set si = Nothing
    Set ptField = Nothing

End Sub

Protected: All In One

admin — Tue, 16 Jul 2024 16:09:33 +0000

Excel Based Resume

admin — Tue, 11 Jun 2024 07:29:23 +0000

Creating an Excel-based resume with a dashboard can effectively showcase your skills and experience in data analytics, Excel, VBA, Power BI, Power Query, DAX and related fields. Below is a guide on how to set up your Excel sheet, enter data, and create a visually appealing dashboard.

Sample Excel File Download

Create a dynamic, Excel-based resume by simply updating the provided Excel sheet. This innovative format allows you to input your current and preferred location, education, certifications, experience, designation, skills, tools, and experience summary. Once the data is entered, it automatically generates a professional, dashboard-style resume. Ideal for data analytics professionals, this tool not only showcases your qualifications but also demonstrates your proficiency in Excel, VBA, and dashboard creation. Impress potential employers with a sleek, interactive resume that highlights your expertise in data analytics and related tools. Get your resume dashboard ready with ease!

Conclusion

An Excel-based resume with a dashboard provides a dynamic and visually appealing way to present your qualifications. Regularly update the data and refine the design to maintain its effectiveness. This format not only showcases your technical skills but also your ability to create compelling data visualizations.

Excel Time Tracker for BPO (VBA Macros)

admin — Mon, 10 Jun 2024 14:45:09 +0000

Our BPO Time Tracker is a robust and efficient time management solution developed using Excel and VBA, integrated with Excel, MS Access, and SQL Server database. Designed to simplify the tracking of employee work hours and enhance productivity, this application offers a seamless experience for both administrators and users.

How It Works:

The BPO Time Tracker operates on a foundation of Excel, VBA, and an MS Access database. Depending on the work environment user can select a specific version. The Admin or Team Leader places the MS Access database on a common drive accessible to all users. SQL queries add and retrieve data from the database, ensuring efficient and accurate data management. Before distribution, the Excel add-in needs to be configured, making it easy to roll out across your organization.

Advantages of the BPO Time Tracker:

No Installation Required:
- The application is fully functional without the need for any installation, simplifying deployment across multiple systems.
User-Friendly:
- No special skills are required to use the application, making it accessible and ready to use for all employees from day one.
Unlimited Users:
- There are no restrictions on the number of users who can utilize the application, ensuring scalability as your team grows.
Comprehensive Monitoring:
- The application is an excellent tool for monitoring working details and collecting raw data for dashboard reports, providing valuable insights into employee productivity.
Compatibility:
- The BPO Time Tracker works seamlessly on Citrix, virtual desktops, or remote desktops, ensuring flexibility in various work environments.
Total Time Monitoring:
- It monitors the total time users spend away from their computers, helping to track productivity accurately.
System Lock Functionality:
- The application can force the system to lock after a specified period of inactivity and start recording time under ‘Others’, ensuring that all time is accounted for.
Auto Window Lock:
- An automatic window lock function enhances security and ensures compliance with company policies.
Automatic Updates:
- The application supports auto-update functionality, ensuring that all users have the latest features and improvements without manual intervention.
Automatic Database Backup:
- Regular automatic backups of the database protect your data and ensure recovery in case of any issues.
Comprehensive Reporting:
- The application includes several ready-to-export reports:
  - For Users: Daily user data reports.
  - For Users: All-day summary reports.
  - For Admin: Comprehensive data reports for all users between specified dates.
  - For Admin: Real-time current work status reports for all users.
- Additional custom reports can be developed based on specific requirements, available at an additional cost.

Summary:

Our BPO Time Tracker combines the power of Excel, VBA, and MS Access to deliver a comprehensive and user-friendly time tracking solution. With no installation required, compatibility with various virtual environments, and extensive reporting capabilities, this application is designed to enhance productivity and provide valuable insights into employee performance.

For more details or to schedule a demo, please contact us.

XL-ERP (VBA)

admin — Sun, 09 Jun 2024 16:56:42 +0000

Comprehensive Mini ERP Solution Developed Using Excel VBA

We are proud to present our newly developed Mini ERP (Enterprise Resource Planning) application, meticulously crafted using Excel VBA (Visual Basic for Applications). This powerful yet user-friendly system is designed to integrate and streamline the operations of multiple departments within an organization, including HR, Sales, Accounts, Warehouse, Operations, IT, Administration, Chatbot, Logistics, CRM, and Marketing. The goal of this Mini ERP is to enhance operational efficiency, improve data accuracy, and provide comprehensive management insights through seamless data integration and real-time reporting.

Key Features and Functionalities

1. Centralized Data Management: Our Mini ERP system consolidates data from various departments into a single Excel file, ensuring that all information is easily accessible and manageable. This centralization eliminates the need for multiple disparate systems, reducing the risk of data duplication and inconsistencies.

2. Department-Specific Modules: Each department has its own dedicated module within the system:

HR: Employee records, payroll management, leave tracking, and performance evaluations.
Sales: Sales tracking, customer relationship management, order processing, and sales analytics.
Accounts: Financial accounting, invoicing, expense tracking, and budget management.
Warehouse: Inventory management, stock tracking, and supplier management.
Operations: Process optimization, workflow management, and production scheduling.
IT: Asset management, IT support tickets, and software inventory.
Administration: Office management, document tracking, and meeting scheduling.
Chatbot: Integration for customer queries, support ticket generation, and automated responses.
Logistics: Shipment tracking, delivery scheduling, and fleet management.
CRM: Customer data management, interaction tracking, and lead management.
Marketing: Campaign management, market analysis, and promotional activities.

3. MIS Reporting: Our system includes a robust MIS (Management Information System) reporting feature that generates detailed reports across all departments. These reports provide critical insights into various operational aspects, helping management make informed decisions. Key performance indicators (KPIs) are visualized through charts and graphs, making it easier to track progress and identify areas for improvement.

4. User-Friendly Interface: Despite the complex functionalities, the application maintains a user-friendly interface. The use of Excel ensures familiarity for most users, minimizing the learning curve. Additionally, the VBA scripts automate routine tasks, reducing manual effort and the potential for human error.

5. Real-Time Data Updates: The Mini ERP system ensures that data across all departments is updated in real-time. This feature is crucial for maintaining accurate records and providing up-to-date information for reporting and decision-making.

6. Customizability and Scalability: The application is highly customizable to fit the unique needs of different organizations. It is also scalable, and capable of handling increasing amounts of data and more complex processes as the organization grows.

7. Security and Data Integrity: We prioritize data security and integrity. The system includes

#xlERP, #ExcelERP, #VBAERP, #ExcelMacroERP, #EasyERP, #excelmacroclassesERP

All In One (VBA)

admin — Sat, 08 Jun 2024 14:42:45 +0000

Excel VBA Automation Tool for Efficient Data Management

Introducing our Excel VBA Automation Tool—an all-in-one solution designed to streamline your Excel tasks and enhance productivity. Developed with a suite of powerful features, this tool is perfect for anyone looking to simplify their Excel workflows. Here are the key features included in this robust tool:

Remove Entire Blank Rows: Effortlessly clean up your worksheets by removing completely empty rows, ensuring your data is compact and organized.
Remove Blank Cells from the Right: Automatically eliminate trailing blank cells in rows, maintaining a tidy dataset.
Remove All Images and Shapes: Instantly clear all images and shapes from your worksheets, leaving only the essential data.
Insert Comments in Selection: Quickly add comments to selected cells, making your spreadsheets more informative.
Insert Comments as per Values: Enhance your data by inserting comments based on cell values, providing additional context or instructions.
Remove All Codes and Forms: Clean your active workbook by removing all VBA code and forms, ensuring a fresh start.
Unhide All Hidden Sheets: Unhide all hidden sheets in your workbook with a single click, provided no password protection is set.
Protect All Sheets with One Password: Secure your entire workbook by protecting all sheets with a single password, safeguarding your data.
Unprotect All Sheets with One Password: Easily unprotect all sheets in your workbook using one password, giving you quick access to all data.
Get Outlook Info from Employee ID: Automatically retrieve Outlook information based on employee IDs listed in Column A.
Indexing of Sheets: Create an organized index of all sheets in your workbook for easy navigation.
Indexing within Each Sheet: Generate an index within each sheet, providing a quick reference to important sections.
Export Sheets in Separate Files: Save each sheet in your workbook as a separate file, simplifying data sharing and management.
Assign Self-Hyperlink in Selected Cell: Add self-referential hyperlinks to selected cells, enabling easy navigation within the sheet.
Find and Replace Multiple Values from Notepad File: Use an Excel list to find and replace multiple values in a Notepad file, streamlining text processing tasks.
Hyperlink Folder Paths in Active Cell: Automatically convert folder paths in active cells into clickable hyperlinks for easy access.
Hyperlink File Paths in Active Cell: Turn file paths in active cells into hyperlinks, allowing quick file opening.
Consolidate Excel Files: Merge multiple Excel files into one comprehensive workbook, simplifying data analysis and reporting.
Split Data from Table to New Sheet: Extract and filter data from a table to a new sheet based on specified criteria.
Split Data from Table to New File: Extract and filter data from a table to a new file, making it easy to share specific data subsets.
File Listing from One Folder: Generate a list of all files in a specified folder, facilitating file management and organization.
Folder Detail from One Folder: Obtain detailed information about the contents of a folder, including file types and sizes.
Export All VBA Code to Text File: Save all VBA code from the active workbook to a text file for backup or review purposes.
Reset Excel, User Role, Domain, and Check Expiry with MySecurity: Manage and reset Excel settings, user roles, and domains, and check the expiry using the MySecurity feature.
Detail of Macro with Code Number: Provide detailed information about each macro along with its code number for easy reference.
Out of Range Handling: Efficiently manage and handle out-of-range errors to ensure your data processing is smooth and error-free.

This comprehensive tool is designed to save you time and enhance your efficiency by automating repetitive tasks and ensuring your data is always organized and accessible.

Why Choose Our Excel VBA Automation Tool?

Efficiency: Automate repetitive tasks and reduce manual effort.
Accuracy: Minimize errors with precise data management functions.
Convenience: Simplify complex data operations with a user-friendly interface.
Security: Protect your data with robust security features.
Versatility: Suitable for various industries and data management needs.

Transform your Excel experience and unlock new levels of productivity with our Excel VBA Automation Tool. Contact us today to learn more or to purchase your copy!

#ExcelAutomation #VBATool #DataManagement #ProductivityBoost #DataCleaning #ExcelExperts #StreamlineWorkflows #BusinessEfficiency