admin – ExcelMacroClasses.com

VBACODE

admin — Thu, 27 Feb 2025 12:45:36 +0000

This Page is only for Temp Code do not past and permanent code to use.

Test

admin — Wed, 29 Jan 2025 08:47:30 +0000

Sub CopyThreeSheetsToNewWorkbook()
    Dim wbSource As Workbook
    Dim wbDestination As Workbook
    Dim sheetNames As Variant
    Dim wsSource As Worksheet, wsDestination As Worksheet
    Dim rngSource As Range
    Dim lastRow As Long, lastCol As Long
    Dim i As Long
 
    ' Set reference to the source workbook (current workbook)
    Set wbSource = ThisWorkbook
 
    ' Define the sheet names to copy
    sheetNames = Array("myAdmin", "Temp", "Sheet1")
 
    ' Create a new workbook for the destination
    Set wbDestination = Workbooks.Add
 
    ' Loop through each sheet to copy data
    For i = LBound(sheetNames) To UBound(sheetNames)
        ' Set source and destination worksheets
        Set wsSource = wbSource.Sheets(sheetNames(i))
        If i = 0 Then
            Set wsDestination = wbDestination.Sheets(1)
        Else
            Set wsDestination = wbDestination.Sheets.Add(After:=wbDestination.Sheets(wbDestination.Sheets.Count))
        End If
        wsDestination.Name = wsSource.Name
 
        ' Determine the range to copy
        lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
        lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
        Set rngSource = wsSource.Range("A1", wsSource.Cells(lastRow, lastCol))
 
        ' Copy and paste data
        rngSource.Copy
        wsDestination.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
    Next i
 
    MsgBox "Data from three sheets has been copied successfully!", vbInformation
End Sub

CopySheetsToNewWorkbook

admin — Wed, 29 Jan 2025 08:34:55 +0000

Sub CopyThreeSheetsToNewWorkbook()
    Dim wbSource As Workbook
    Dim wbDestination As Workbook
    Dim sheetNames As Variant
    Dim wsSource As Worksheet, wsDestination As Worksheet
    Dim rngSource As Range
    Dim lastRow As Long, lastCol As Long
    Dim i As Long
 
    ' Set reference to the source workbook (current workbook)
    Set wbSource = ThisWorkbook
 
    ' Define the sheet names to copy
    sheetNames = Array("myAdmin", "Temp", "Sheet1")
 
    ' Create a new workbook for the destination
    Set wbDestination = Workbooks.Add
 
    ' Loop through each sheet to copy data
    For i = LBound(sheetNames) To UBound(sheetNames)
        ' Set source and destination worksheets
        Set wsSource = wbSource.Sheets(sheetNames(i))
        If i = 0 Then
            Set wsDestination = wbDestination.Sheets(1)
        Else
            Set wsDestination = wbDestination.Sheets.Add(After:=wbDestination.Sheets(wbDestination.Sheets.Count))
        End If
        wsDestination.Name = wsSource.Name
 
        ' Determine the range to copy
        lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
        lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
        Set rngSource = wsSource.Range("A1", wsSource.Cells(lastRow, lastCol))
 
        ' Copy and paste data
        rngSource.Copy
        wsDestination.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
    Next i
 
    MsgBox "Data from three sheets has been copied successfully!", vbInformation
End Sub

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

Sub CopyThreeSheetsToNewWorkbook()
    Dim wbSource As Workbook
    Dim wbDestination As Workbook
    Dim sheetNames As Variant
    Dim wsSource As Worksheet, wsDestination As Worksheet
    Dim rngSource As Range
    Dim lastRow As Long, lastCol As Long
    Dim i As Long
 
    ' Set reference to the source workbook (current workbook)
    Set wbSource = ThisWorkbook
 
    ' Define the sheet names to copy
    sheetNames = Array("myAdmin", "Temp", "Sheet1")
 
    ' Create a new workbook for the destination
    Set wbDestination = Workbooks.Add
 
    ' Loop through each sheet to copy data
    For i = LBound(sheetNames) To UBound(sheetNames)
        ' Set source and destination worksheets
        Set wsSource = wbSource.Sheets(sheetNames(i))
        If i = 0 Then
            Set wsDestination = wbDestination.Sheets(1)
        Else
            Set wsDestination = wbDestination.Sheets.Add(After:=wbDestination.Sheets(wbDestination.Sheets.Count))
        End If
        wsDestination.Name = wsSource.Name
 
        ' Determine the range to copy
        lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
        lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
        Set rngSource = wsSource.Range("A1", wsSource.Cells(lastRow, lastCol))
 
        ' Copy and paste data
        rngSource.Copy
        wsDestination.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
    Next i
 
    MsgBox "Data from three sheets has been copied successfully!", vbInformation
End Sub

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.