Excel VBA

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim chromePath As String, searchTerm1 As String, searchTerm2 As String

    If Not Intersect(Target, Me.Range("C2:C100")) Is Nothing Then

        chromePath = "C:\Program Files\Google\Chrome\Application\chrome.exe"

        

        With Me.Cells(Target.Row, "B")

            searchTerm1 = "%22" & .Value & "%22"

            searchTerm2 = "%22" & .Value & "%22%20AND%20(lunder%20OR%20lawsuit%20scandal)"

        End With

        Shell chromePath & " --new-tab " & """https://www.google.com/search?q=" & searchTerm1 & """", vbNormalFocus

        Shell chromePath & " --new-tab " & """https://www.google.com/search?q=" & searchTerm2 & """", vbNormalFocus

        Cancel = True

    End If

End Sub

______________

Sub SwitchToSpecificChromeTab() Dim shell As Object Dim tabTitle As String Dim retry As Integer Set shell = CreateObject("WScript.Shell") tabTitle = "Gmail" ' Partial title of the tab you want ' Try to activate Chrome If Not (shell.AppActivate("Chrome") Or shell.AppActivate("Google Chrome")) Then MsgBox "Chrome window not found", vbExclamation Exit Sub End If ' Focus address bar and search for tab shell.SendKeys "^l" ' Ctrl+L focuses address bar shell.SendKeys tabTitle shell.SendKeys "{ENTER}" ' Small delay to allow tab switch Application.Wait Now + TimeValue("00:00:01") End Sub

=========================================================

FILTER BY YELLOW COLOR

-------------------------------------------

Sub FilterByYellowAndOtherFillAndCopy() Dim wsSource As Worksheet Dim wsAlerted As Worksheet Dim wsNonAlerted As Worksheet Dim lastRow As Long Dim lastCol As Long Dim colTransactionKey As Long Dim headerRange As Range Dim cell As Range Dim sheetName As String Dim alertedSheetName As String Dim nonAlertedSheetName As String Dim filterRange As Range Dim visibleRange As Range Dim yellowColor As Long Dim r As Long Dim nonAlertedRow As Long ' Define the yellow color code (Excel standard yellow) yellowColor = RGB(255, 255, 0) ' Set the source worksheet as the active sheet Set wsSource = ActiveSheet sheetName = wsSource.Name ' Find last row with data in the sheet lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row ' Find last column with data in row 1 (headers) lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column ' Find the "Transaction Key" column by header name in row 1 Set headerRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol)) colTransactionKey = 0 For Each cell In headerRange If Trim(cell.Value) = "Transaction Key" Then colTransactionKey = cell.Column Exit For End If Next cell If colTransactionKey = 0 Then MsgBox "Column 'Transaction Key' not found in the first row.", vbCritical Exit Sub End If ' Define the filter range (including headers) Set filterRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)) ' Remove any existing filter If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False End If ' Delete already existing alerted and non-alerted sheets to avoid errors alertedSheetName = sheetName & "-A" nonAlertedSheetName = sheetName & "-NA" Application.DisplayAlerts = False On Error Resume Next Worksheets(alertedSheetName).Delete Worksheets(nonAlertedSheetName).Delete On Error GoTo 0 Application.DisplayAlerts = True ' 1) Filter by yellow fill color On Error Resume Next filterRange.AutoFilter Field:=colTransactionKey, Criteria1:=yellowColor, Operator:=xlFilterCellColor If Err.Number <> 0 Then MsgBox "Filtering by cell color is not supported in this Excel version.", vbCritical On Error GoTo 0 Exit Sub End If On Error GoTo 0 ' Check visible cells excluding header On Error Resume Next Set visibleRange = filterRange.Offset(1, 0).Resize(filterRange.Rows.Count - 1).SpecialCells(xlCellTypeVisible) On Error GoTo 0 ' Create alerted sheet Set wsAlerted = Worksheets.Add(After:=Worksheets(Worksheets.Count)) wsAlerted.Name = alertedSheetName ' Copy headers wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol)).Copy wsAlerted.Range("A1") If Not visibleRange Is Nothing Then ' Copy filtered yellow rows visibleRange.Copy wsAlerted.Range("A2") Else MsgBox "No rows with yellow fill in 'Transaction Key' column found.", vbInformation End If ' Remove filter for next step wsSource.AutoFilterMode = False ' 2) Copy all rows where 'Transaction Key' fill color is NOT yellow (including no fill or other colors) ' Create Non-alerted sheet and copy headers Set wsNonAlerted = Worksheets.Add(After:=Worksheets(Worksheets.Count)) wsNonAlerted.Name = nonAlertedSheetName ' Copy headers wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol)).Copy wsNonAlerted.Range("A1") ' Initialize row counter for Non-alerted sheet data start at row 2 nonAlertedRow = 2 ' Loop through each data row and check fill color in Transaction Key column For r = 2 To lastRow ' If fill color not yellow (including no fill), copy entire row to Non-alerted sheet If wsSource.Cells(r, colTransactionKey).Interior.Color <> yellowColor Then wsSource.Range(wsSource.Cells(r, 1), wsSource.Cells(r, lastCol)).Copy wsNonAlerted.Cells(nonAlertedRow, 1) nonAlertedRow = nonAlertedRow + 1 End If Next r MsgBox "Completed copying filtered data to '" & alertedSheetName & "' and '" & nonAlertedSheetName & "'.", vbInformation End Sub --------------------------- FASTER ========================== ======================================= Sub FilterByYellowAndOtherFillAndCopy() Dim wsSource As Worksheet Dim wsAlerted As Worksheet Dim wsNonAlerted As Worksheet Dim lastRow As Long Dim lastCol As Long Dim colTransactionKey As Long Dim headerRange As Range Dim cell As Range Dim alertedSheetName As String Dim nonAlertedSheetName As String Dim yellowColor As Long Dim r As Long, c As Long Dim alertedCount As Long Dim nonAlertedCount As Long Dim data As Variant Dim alertedData() As Variant Dim nonAlertedData() As Variant ' Define the yellow color code (Excel standard yellow) yellowColor = RGB(255, 255, 0) ' Use active sheet as source Set wsSource = ActiveSheet ' Find last row and last column lastRow = wsSource.Cells(wsSource.rows.Count, 1).End(xlUp).Row lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column ' Find "Transaction Key" column index Set headerRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol)) colTransactionKey = 0 For Each cell In headerRange If Trim(cell.Value) = "Transaction Key" Then colTransactionKey = cell.Column Exit For End If Next cell If colTransactionKey = 0 Then MsgBox "Column 'Transaction Key' not found in the first row.", vbCritical Exit Sub End If ' Prepare output sheet names alertedSheetName = wsSource.Name & "-A" nonAlertedSheetName = wsSource.Name & "-NA" ' Delete existing sheets if any Application.DisplayAlerts = False On Error Resume Next Worksheets(alertedSheetName).Delete Worksheets(nonAlertedSheetName).Delete On Error GoTo 0 Application.DisplayAlerts = True ' Read source data into array data = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).Value ' Pre-allocate arrays to maximum possible size ReDim alertedData(1 To lastRow, 1 To lastCol) ReDim nonAlertedData(1 To lastRow, 1 To lastCol) ' Copy headers fully to both arrays (row 1) For c = 1 To lastCol alertedData(1, c) = data(1, c) nonAlertedData(1, c) = data(1, c) Next c ' Initialize counts for rows added (excluding header) alertedCount = 0 nonAlertedCount = 0 ' Loop through data rows starting at 2 (data rows) For r = 2 To lastRow If wsSource.Cells(r, colTransactionKey).Interior.Color = yellowColor Then alertedCount = alertedCount + 1 For c = 1 To lastCol alertedData(alertedCount + 1, c) = data(r, c) Next c Else nonAlertedCount = nonAlertedCount + 1 For c = 1 To lastCol nonAlertedData(nonAlertedCount + 1, c) = data(r, c) Next c End If Next r ' Create Alerted sheet and copy only used data Set wsAlerted = Worksheets.Add(After:=Worksheets(Worksheets.Count)) wsAlerted.Name = alertedSheetName If alertedCount > 0 Then wsAlerted.Range(wsAlerted.Cells(1, 1), wsAlerted.Cells(alertedCount + 1, lastCol)).Value = _ SliceArray(alertedData, alertedCount + 1, lastCol) Else ' Only header if no data rows wsAlerted.Range(wsAlerted.Cells(1, 1), wsAlerted.Cells(1, lastCol)).Value = _ SliceArray(alertedData, 1, lastCol) End If ' Create Non-Alerted sheet and copy only used data Set wsNonAlerted = Worksheets.Add(After:=Worksheets(Worksheets.Count)) wsNonAlerted.Name = nonAlertedSheetName If nonAlertedCount > 0 Then wsNonAlerted.Range(wsNonAlerted.Cells(1, 1), wsNonAlerted.Cells(nonAlertedCount + 1, lastCol)).Value = _ SliceArray(nonAlertedData, nonAlertedCount + 1, lastCol) Else ' Only header if no data rows wsNonAlerted.Range(wsNonAlerted.Cells(1, 1), wsNonAlerted.Cells(1, lastCol)).Value = _ SliceArray(nonAlertedData, 1, lastCol) End If MsgBox "Completed copying filtered data to '" & alertedSheetName & "' and '" & nonAlertedSheetName & "'.", vbInformation End Sub ' Helper function to get a slice of 2D array from (1,1) to (rows, cols) Private Function SliceArray(arr As Variant, rows As Long, cols As Long) As Variant Dim i As Long, j As Long Dim result() As Variant ReDim result(1 To rows, 1 To cols) For i = 1 To rows For j = 1 To cols result(i, j) = arr(i, j) Next j Next i SliceArray = result End Function

===========

VBA CODE FOR ADD NEW SHEET

============

Sub FilterByYellowAndOtherFillAndCopy()

    Dim wsSource As Worksheet

    Dim wsAlerted As Worksheet

    Dim wsNonAlerted As Worksheet

    Dim lastRow As Long

    Dim lastCol As Long

    Dim colTransactionKey As Long

    Dim headerRange As Range

    Dim cell As Range

    Dim alertedSheetName As String

    Dim nonAlertedSheetName As String

    Dim yellowColor As Long

    Dim r As Long, c As Long

    Dim alertedCount As Long

    Dim nonAlertedCount As Long

    Dim data As Variant

    Dim alertedData() As Variant

    Dim nonAlertedData() As Variant

    

    ' Define the yellow color code (Excel standard yellow)

    yellowColor = RGB(255, 255, 0)

    

    ' Use active sheet as source

    Set wsSource = ActiveSheet

    

    ' Find last row and last column

    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row

    lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column

    

    ' Find "Transaction Key" column index

    Set headerRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol))

    colTransactionKey = 0

    For Each cell In headerRange

        If Trim(cell.Value) = "Transaction Key" Then

            colTransactionKey = cell.Column

            Exit For

        End If

    Next cell

    

    If colTransactionKey = 0 Then

        MsgBox "Column 'Transaction Key' not found in the first row.", vbCritical

        Exit Sub

    End If

    

    ' Prepare output sheet names

    alertedSheetName = wsSource.Name & "-A"

    nonAlertedSheetName = wsSource.Name & "-NA"

    

    ' Delete existing sheets if any

    Application.DisplayAlerts = False

    On Error Resume Next

    Worksheets(alertedSheetName).Delete

    Worksheets(nonAlertedSheetName).Delete

    On Error GoTo 0

    Application.DisplayAlerts = True

    

    ' Read source data into array

    data = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).Value

    

    ' Pre-allocate arrays to maximum possible size

    ReDim alertedData(1 To lastRow, 1 To lastCol)

    ReDim nonAlertedData(1 To lastRow, 1 To lastCol)

    

    ' Copy headers fully to both arrays (row 1)

    For c = 1 To lastCol

        alertedData(1, c) = data(1, c)

        nonAlertedData(1, c) = data(1, c)

    Next c

    

    ' Initialize counts for rows added (excluding header)

    alertedCount = 0

    nonAlertedCount = 0

    

    ' Loop through data rows starting at 2 (data rows)

    For r = 2 To lastRow

        If wsSource.Cells(r, colTransactionKey).Interior.Color = yellowColor Then

            alertedCount = alertedCount + 1

            For c = 1 To lastCol

                alertedData(alertedCount + 1, c) = data(r, c)

            Next c

        Else

            nonAlertedCount = nonAlertedCount + 1

            For c = 1 To lastCol

                nonAlertedData(nonAlertedCount + 1, c) = data(r, c)

            Next c

        End If

    Next r

    

    ' Create Alerted sheet and copy only used data

    Set wsAlerted = Worksheets.Add(After:=wsSource)

    wsAlerted.Name = alertedSheetName

    If alertedCount > 0 Then

        wsAlerted.Range(wsAlerted.Cells(1, 1), wsAlerted.Cells(alertedCount + 1, lastCol)).Value = _

            SliceArray(alertedData, alertedCount + 1, lastCol)

        ' Apply yellow color to alerted data rows (excluding header)

        wsAlerted.Range(wsAlerted.Cells(2, 1), wsAlerted.Cells(alertedCount + 1, lastCol)).Interior.Color = yellowColor

    Else

        ' Only header if no data rows

        wsAlerted.Range(wsAlerted.Cells(1, 1), ws