VBA Algorithms - abdullahbintahir/Python-Snippet GitHub Wiki

'Copy pasting data from another workbook

Sub Automation()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

MAcro_Workbook = ActiveWorkbook.Name
Input_Workbook_Path = Application.GetOpenFilename(, , "Select MSP Opportunity Pricing Tracker")

'Opening Input file

    Sheets("Deal Summary").Cells.Clear
    Workbooks.Open Input_Workbook_Path
    Input_Workbook = ActiveWorkbook.Name

'Copying results to Macro File
    Range("A4", Range("A4").End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Workbooks(MAcro_Workbook).Sheets("Deal Summary").Activate
    Range("B1").PasteSpecial
    Workbooks(Input_Workbook).Close
        
'Formatting sheet
    Cells.WrapText = False
    Rows(1).Font.ThemeColor = xlThemeColorLight1
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Attaching excel file with email and writing that email

    Dim OlApp As Outlook.Application
    Dim ObjMail As Outlook.MailItem

    Set OlApp = Outlook.Application
    Set ObjMail = OlApp.CreateItem(olMailItem)

    With ObjMail
        .Display
        .To = "Email1;Email2,Email3,Email4"
        .CC = "Email5;Email6"
        .Subject = "DetectIT " & Format(Date, "MMMM DD YYYY")
        .HTMLBody = "<div style='font:14 Verdana'>" _
                    & "Hello" & "<br>" & "<br>" _
                    & "I hope this email finds you well" & "<br>" _
                    & "Regards" & "<br>" & .HTMLBody
        .Attachments.Add ActiveWorkbook.FullName

    End With

    Set OlApp = Nothing
    Set ObjMail = Nothing

Insert objects in Bulk and put them in the cell with the object name

Sub Insert_Objects_In_Bulk()

FilePaths = Application.GetOpenFilename(, , , , True)

On Error Resume Next
For Each FilePath In FilePaths
    'Getting file name/label from file path
    Downloads_Path_Len = Len(Environ("USERPROFILE") & "\Downloads\")
    Fixed_Elements_Length = Downloads_Path_Len + 4
    Variable_Elements_Length = Len(FilePath) - Fixed_Elements_Length
    Label = Mid(FilePath, Downloads_Path_Len + 1, Variable_Elements_Length)

    'Selecting cell where the object would be inserted and adding it
    For Each Cell In Range("K1:K1000").Cells
        If Cell.Value Like Label Then
        Cell.Select
        ActiveSheet.OLEObjects.Add(Filename:=FilePath, Link:=False, DisplayAsIcon:=True, IconFileName:="C:\Program Files (x86)\Adobe\Acrobat DC\Acrobat\Acrobat.exe", IconIndex:=0, IconLabel:=Label).Select
        'Formatting Object
        Selection.Height = 10.08
        Selection.Width = 10.08
    End If
    Next Cell
Next FilePath

End Sub

Convert xls files to xlsx in bulk

Sub xlsToXlsx()

Application.DisplayAlerts = False
Fls = Application.GetOpenFilename(, , "Select xls files to convert", , True)


For Each i In Fls
    Set wb = Workbooks.Open(i)
    Nme = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
    wb.SaveAs Nme & ".xlsx"
    wb.Close
    Kill i
Next i

Application.DisplayAlerts = True
MsgBox ("Process Complete")

End Sub

Merge different Excel files

Sub Merge_Data_One_Sheet()

    Application.ScreenUpdating = False
    
    MainFile = ActiveWorkbook.Name
    Fls = Application.GetOpenFilename(, , , , True)
    
    For Each i In Fls
        Range("A1").End(xlDown).Offset(1, 0).Select
        Workbooks.Open i
        TempFile = ActiveWorkbook.Name
        Range("A1").CurrentRegion.Copy
        Workbooks(MainFile).Activate
        ActiveCell.PasteSpecial xlPasteAll
        ActiveCell.EntireRow.Delete
        Workbooks(TempFile).Close
    Next i
       
    Application.ScreenUpdating = True

End Sub

Sub Merge_Data_To_Each_Sheet()

Application.AskToUpdateLinks = False
Application.DisplayAlerts = False


abc = Application.GetOpenFilename(, , , , True)
Consolidated_File = ActiveWorkbook.Name

For Each i In abc
    Workbooks.Open i
    ActiveSheet.ShowAllData
    book_nme = ActiveWorkbook.Name
    sht_nme = Left(book_nme, Len(book_nme) - 5)
    Cells.Copy
    Workbooks(Consolidated_File).Activate
    Sheets.Add.Name = sht_nme
    Range("A1").PasteSpecial
    Workbooks(book_nme).Close
Next i
    

End Sub

Renaming Excel files in bulk

Sub Renaming()

Application.DisplayAlerts = False
Fls = Application.GetOpenFilename(, , , , True)

For Each i In Fls
    Workbooks.Open (i)
    Nme = ActiveWorkbook.Name
    Mth = Left(Nme, 2)
    Yr = Mid(Nme, 7, 4)
    ActiveWorkbook.SaveAs Mth & "-" & Yr & ".xlsx"
    ActiveWorkbook.Close
    Kill i
Next i

Application.DisplayAlerts = True

End Sub

Clearing data from a range of sheets

For Each sht In ActiveWorkbook.Sheets(Array("Deal Summary", "Upcoming Activities", "Pricing Models - Strategy", "Admin - Issues", "PTO"))
        sht.Cells.Clear
Next sht

Copying multiple sheets from another file

Workbooks(Input_Workbook).Sheets(Array("Sht1", "Sht2", "Sht3", "Sht4")).Copy After:=Workbooks(MAcro_Workbook).Sheets(4)

Creating a log

    Sheets("Deal Summary").Range("A1").CurrentRegion.Offset(1).Copy
    Sheets("Log").Activate
    Range("A1048576").End(xlUp).Offset(1).PasteSpecial
    
    Starting_Row = Range("Z1048576").End(xlUp).Offset(1).Row
    No_Of_Rows = Range("A1").End(xlDown).Row
    Range("Z1048576").End(xlUp).Offset(1).Select
    Selection.Value = Now
    Selection.AutoFill Destination:=Range("Z" & Starting_Row, "Z" & No_Of_Rows), Type:=xlFillCopy

Putting Progress Bar at the main sheet

    Range("C8").Font.Color = -16776961
    Range("C8").Font.Bold = True
    Range("C8").Font.Size = 20
    Range("C8").Value = "Processing........."
    Range("C9:F9").Borders.LineStyle = xlContinuous
    Range("C9").Interior.Color = RGB(146, 208, 80)
    Application.Wait Now + TimeValue("00:00:01")
    Application.ScreenUpdating = False

Updating status at various intervals
    Sheets("").activate
    Application.ScreenUpdating = True
    Range("").Interior.Color = RGB(146, 208, 80)
    Application.Wait Now + TimeValue("00:00:01")
    Application.ScreenUpdating = False

Hide/unhide rows and columns based on cell value or range values

Private Sub Worksheet_Change(ByVal Target As Range)

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

'Making "custom activity name" rows visibile based on cell C4 value
    n = Range("C4").Value + 6
    
        If Target.Address = "$C$4" Then
            Rows("6:" & n).Hidden = False
            Rows(n + 1 & ":31").Hidden = True
        End If
        
        If Target.Address = "$C$4" Then
            If Target.Value = 0 Then
                Rows(6).Hidden = True
                Rows("35:685").Hidden = True
            End If
        End If

'Making "custom activity" further details rows visibile/ hidden based on each custom activity scope
    'Visible
    If Not Intersect(Target, Range("B7:B30")) Is Nothing Then
        For Each cell In Target
            If cell.Value = "Yes" Then
                Activity_Name = cell.Offset(0, -1).Value
                Rows("35:36").Hidden = False
                For Each innercell In Range("C37:C684")
                    If innercell.Value = Activity_Name Then
                        innercell.EntireRow.Hidden = False
                        If innercell.Offset(1).Value = "" Then
                            innercell.Offset(1).EntireRow.Hidden = False
                         End If
                    End If
                Next innercell
                Rows(685).Hidden = False
            End If
        Next cell
    End If

    'Hide
    If Not Intersect(Target, Range("B7:B30")) Is Nothing Then
        For Each cell In Target
            If cell.Value = "No" Then
                Activity_Name = cell.Offset(0, -1).Value
                For Each innercell In Range("C37:C684")
                    If innercell.Value = Activity_Name Then
                        innercell.EntireRow.Hidden = True
                        If innercell.Offset(1).Value = "" Then
                            innercell.Offset(1).EntireRow.Hidden = True
                        End If
                    End If
                Next innercell
            End If
        Next cell
    End If

'Application.ScreenUpdating = True
'Application.Calculation = xlCalculationAutomatic
Worksheets("Custom Request").Calculate



End Sub

Private Sub Worksheet_Activate()

'Making number of columns visible/ hidden based on years of contract duration
    n = Sheets("DI - Project Details").Range("C21").Value + 5
    
    If Sheets("Custom Request").Activate Then
        Range(Cells(1, 6), Cells(1, n)).EntireColumn.Hidden = False
        Range(Cells(1, n + 1), Cells(1, 15)).EntireColumn.Hidden = True
'Making transition column visible or hidden based on trasition requirement
    If Sheets("DI - Project Details").Range("C25").Value = "No" Then
        Columns(5).Hidden = False
    Else
     Columns(5).Hidden = True
    End If
    End If

End Sub

Convert emails to hyperlinks

Sub ConvertEmailsToHyperlinks()
    Dim cell As Range
    
    For Each cell In Range("D3:D250")
        If InStr(1, cell.Value, "@") > 0 Then
            ActiveSheet.Hyperlinks.Add _
                Anchor:=cell, _
                Address:="mailto:" & cell.Value, _
                TextToDisplay:=cell.Value
        End If
    Next cell
End Sub

Copying selective columns from other excel files. This code filters the columns in input file Unhides any hidden column execute the code only if filtering results in any value Adds additional data to the left of the pasted data

Sub Merge_IncorrectCoding()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

'Input all parameters
Set Output_File = ActiveWorkbook.Sheets("Data- Incorrect Coding")
FirstColumnToFill = 3
InputFile_MainSheet = "Concur Data Reconciliation"
InputFile_HeaderRow = 9
Filter_Column_name = "Notes"
Filter_Column_Criteria = Array("Incorrect expense type", "Incorrect Coding")
Copy_Column_Names = Array("Report Key", "Expense Type", "Approved Amount")

'Clearing existing data
Output_File.Rows("2:1048576").Clear

'Getting directory of all files to get input data from
Fls = Application.GetOpenFilename(, , , , True)
For Each fle In Fls
    Workbooks.Open fle
    Set input_file = ActiveWorkbook
    Set input_file_MainSheet = ActiveWorkbook.Sheets(InputFile_MainSheet)
    Set input_file_HeaderRow = input_file_MainSheet.Rows(InputFile_HeaderRow)
    input_file_MainSheet.Activate
    
    'Clearing existing filters (if any)
    On Error Resume Next
    input_file_MainSheet.ShowAllData
    On Error GoTo 0
    
    'Unhiding any hidden columns
    input_file_MainSheet.Cells.EntireColumn.Hidden = False
    
    'Measing data dimensions
    Filter_Column_Number = input_file_HeaderRow.Find(Filter_Column_name).Column
    max_rows = Range("A1048576").End(xlUp).Row
    
    'Filtering
    input_file_MainSheet.Range("A" & InputFile_HeaderRow).CurrentRegion.AutoFilter Field:=input_file_HeaderRow.Find(Filter_Column_name).Column, Criteria1:=Filter_Column_Criteria, Operator:=xlFilterValues
    
    'Executing code only if filtering results in any value
    For Each cell In Range(Cells(InputFile_HeaderRow + 1, Filter_Column_Number), Cells(max_rows, Filter_Column_Number))
        If cell.EntireRow.Hidden = False Then
            'Copy Pasting columns
            i = FirstColumnToFill
            For Each clm In Copy_Column_Names
                input_file_MainSheet.Activate
                input_file_HeaderRow.Find(clm).Select
                Range(Selection, Selection.End(xlDown)).Copy
                Delete_Row = Output_File.Cells(1048576, i).End(xlUp).Offset(1).Row
                'Output_File.Cells(1048576, i).End(xlUp).Offset(1).PasteSpecial xlPasteFormats
                Output_File.Cells(1048576, i).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                i = i + 1
            Next clm

            'Deleting copied header row
            Output_File.Rows(Delete_Row).Delete

            'Copying Partner Name
            Output_File.Activate
            Output_File.Range("A1048576").End(xlUp).Offset(1).Select
            Start_Cell = Selection.Address
            End_Cell = "A" & Application.WorksheetFunction.CountA(Columns("C:C"))
            Output_File.Range(Start_Cell, End_Cell).Value = input_file_MainSheet.Range("B3").Value

            'Copying EA Name
            Output_File.Range("B1048576").End(xlUp).Offset(1).Select
            Start_Cell = Selection.Address
            End_Cell = "B" & Application.WorksheetFunction.CountA(Columns("C:C"))
            Output_File.Range(Start_Cell, End_Cell).Value = input_file_MainSheet.Range("B7").Value
            Exit For
        End If
    Next cell
    'Closing Workbook
    input_file.Close
Next fle
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Find certain keyword in a specifc sheet for a range of workbooks

Sub Find_Keyword_In_Sheets()
    
    Fls = Application.GetOpenFilename(, , , , True)
    
    For Each i In Fls
        Set Temp_Workbook = Workbooks.Open(i)
        Temp_Workbook.Sheets("DetectIT").Rows(5).Find("Auditor").Copy
        Temp_Workbook.Close
    Next i
       
End Sub

Selenium Basic Web automation

Sub GoToConcur()

    Dim driver As New WebDriver
    Dim iframe As Object
    
    downloadPath = "C:\Users\moxtahir\Downloads\"
    
    

    'Opening Edge browser and the main website
    driver.Start "edge", "C:\Users\moxtahir\AppData\Local\SeleniumBasic\edgedriver.exe"
    driver.Get ("https://eu1.concursolutions.com/")
    driver.AddAdditionalCapability "ms:edgeOptions", "{""prefs"":{""download.default_directory"":""" & downloadPath & """}}"
    driver.Window.Maximize
 
    
    'Logging in
    driver.FindElementByCss("#username-input").SendKeys ("[email protected]")
    driver.FindElementById("btnSubmit").Click
    driver.FindElementByXPath("//body[1]/div[2]/div[1]/div[1]/div[1]/div[1]/div[1]/section[1]/div[1]/div[1]/div[2]/div[1]/div[1]/button[1]").Click
    
    'Going to Cognos
    driver.FindElementByXPath("//body[1]/otsitewarning[1]/div[1]/div[1]/div[2]/div[1]/div[1]/nav[1]/ul[1]/li[5]/span[1]").Click
    driver.FindElementByXPath("//body[1]/otsitewarning[1]/div[1]/div[1]/div[2]/div[1]/div[1]/nav[1]/ul[1]/li[5]/ul[1]/li[1]/a[1]/span[1]").Click
    driver.SwitchToNextWindow
    driver.Wait (1000)

    'Opening DetectIT report
    driver.FindElementByXPath("//body[1]/div[2]/div[2]/div[3]/div[1]/div[1]/div[4]/span[1]/button[1]").Click
    driver.FindElementByXPath("//body[1]/div[2]/div[2]/div[3]/div[2]/div[1]/div[4]/div[1]/div[3]/div[1]/div[1]/div[1]/table[1]/tbody[1]/tr[3]/td[2]/div[1]/div[1]").Click
    driver.FindElementByXPath("//body[1]/div[2]/div[2]/div[3]/div[2]/div[1]/div[4]/div[1]/div[3]/div[1]/div[1]/div[1]/table[1]/tbody[1]/tr[2]/td[2]/div[1]/div[1]").Click
    driver.FindElementByXPath("//body[1]/div[2]/div[2]/div[3]/div[2]/div[1]/div[4]/div[1]/div[3]/div[1]/div[1]/div[1]/table[1]/tbody[1]/tr[3]/td[2]/div[1]/div[1]").Click
    driver.FindElementByXPath("//body[1]/div[2]/div[2]/div[3]/div[2]/div[1]/div[4]/div[1]/div[1]/div[1]/div[1]/div[3]/div[3]/button[1]").Click
    driver.Wait (1000)
    driver.FindElementByXPath("//body[1 ]/div[2]/div[2]/div[3]/div[2]/div[1]/div[6]/div[1]/div[4]/div[1]/div[2]/span[1]/div[3]/div[1]/div[1]/div[1]/div[1]/input[1]").SendKeys ("DTIT")
    driver.FindElementByXPath("//body[1]/div[2]/div[2]/div[3]/div[2]/div[1]/div[4]/div[1]/div[3]/div[1]/div[1]/div[1]/table[1]/tbody[1]/tr[1]/td[2]/div[1]/div[1]").Click
    driver.Wait (2000)

    'Sending date parameters and running report
    driver.SwitchToFrame ("iFFEB60CB87E74D00A63B32BCC3C8B084")
    driver.FindElementByXPath("//body[1]/form[1]/table[1]/tbody[1]/tr[2]/td[1]/div[1]/div[1]/table[1]/tbody[1]/tr[2]/td[1]/div[1]/table[1]/tbody[1]/tr[1]/td[1]/div[1]/table[1]/tbody[1]/tr[2]/td[2]/div[1]/table[1]/tbody[1]/tr[1]/td[1]/table[1]/tbody[1]/tr[2]/td[1]/table[1]/tbody[1]/tr[1]/td[2]/table[1]/tbody[1]/tr[1]/td[1]/input[1]").Clear
    driver.FindElementByXPath("//body[1]/form[1]/table[1]/tbody[1]/tr[2]/td[1]/div[1]/div[1]/table[1]/tbody[1]/tr[2]/td[1]/div[1]/table[1]/tbody[1]/tr[1]/td[1]/div[1]/table[1]/tbody[1]/tr[2]/td[2]/div[1]/table[1]/tbody[1]/tr[1]/td[1]/table[1]/tbody[1]/tr[2]/td[1]/table[1]/tbody[1]/tr[1]/td[2]/table[1]/tbody[1]/tr[1]/td[1]/input[1]").SendKeys (Date - 365)
    driver.FindElementByXPath("//body[1]/form[1]/table[1]/tbody[1]/tr[2]/td[1]/div[1]/div[1]/table[1]/tbody[1]/tr[2]/td[1]/div[1]/table[1]/tbody[1]/tr[1]/td[1]/div[1]/table[1]/tbody[1]/tr[4]/td[2]/div[2]/button[1]").Click
    driver.Wait (20000)
    driver.SwitchToDefaultContent

    'Downloading report
    driver.FindElementByXPath("//body[1]/div[2]/div[3]/div[1]/div[1]/div[4]/button[1]").Click
    driver.FindElementByXPath("//*[@aria-label='Run Excel data']").Click
    driver.Wait (5000)
    driver.SwitchToNextWindow
    targetWindow = "DTIT - IBM Cognos Viewer - Profile 1 - Microsoft Edge"
    driver.Wait (20000)

Merge Same Cells

Sub mergeSameCells()

Application.DisplayAlerts = False

For Each cell In Range("A2:A2144")
    If cell.Value = cell.Offset(1).Value Then
        Range(cell, cell.Offset(1)).merge
    End If
Next cell

Application.DisplayAlerts = True
End Sub

Clearing the cells if someone tries to enter data in it

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Define the range you want to monitor
    Dim monitoredRange As Range
    Set monitoredRange = Me.Range("I30:BK35") ' Change this to your desired range

    ' Check if the changed cell is within the monitored range
    If Not Intersect(Target, monitoredRange) Is Nothing Then
        ' Disable events to prevent an infinite loop
        Application.EnableEvents = False

        ' Clear the contents of the changed cell
        Target.ClearContents
        MsgBox "Please do not input Judge here!", vbCritical

        ' Re-enable events
        Application.EnableEvents = True
    End If
End Sub

'Undo change if someone tries to change cells

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WatchRange As Range
    Dim IntersectRange As Range
    
    ' Define the range you want to protect
    Set WatchRange = Me.Range("A1:B10") ' Change this to your desired range
    
    ' Check if the changed cell is within the protected range
    Set IntersectRange = Intersect(Target, WatchRange)
    
    If Not IntersectRange Is Nothing Then
        ' If it is, undo the change and show an error message
        Application.EnableEvents = False
        Application.Undo
        MsgBox "You cannot change cells in this range!", vbExclamation
        Application.EnableEvents = True
    End If
End Sub