Test

[Viraj-Sanap]

Check

[Viraj-Sanap]

Sub UpdateRoster() Dim ws As Worksheet Dim wb As Workbook Dim newDataWb As Workbook Dim newDataWs As Worksheet Dim filePath As Variant Dim fileExt As String

' Set the target worksheet
Set ws = ThisWorkbook.Sheets("Roster")

' Prompt the user to select the new data file
filePath = Application.GetOpenFilename(FileFilter:="Excel Files, *.xls; *.xlsx; *.xlsm; *.csv", Title:="Select New Data File")

' Check if the user cancelled the file dialog
If filePath = False Then
    MsgBox "No file selected. Operation cancelled.", vbExclamation
    Exit Sub
End If

' Determine the file extension
fileExt = Right(filePath, Len(filePath) - InStrRev(filePath, "."))

' Open the new data file
Set newDataWb = Workbooks.Open(filePath)

' Assuming the data is in the first sheet of the new data file
Set newDataWs = newDataWb.Sheets(1)

' Clear the existing data in the Roster sheet
ws.Cells.Clear

' Copy new data to the Roster sheet
newDataWs.UsedRange.Copy Destination:=ws.Range("A1")

' Close the new data file
newDataWb.Close SaveChanges:=False

' Notify the user of completion
MsgBox "Roster sheet has been updated successfully.", vbInformation

End Sub

[Viraj-Sanap]

Sub UpdateMonthOld() Dim wsNew As Worksheet Dim wsOld As Worksheet Dim newHeaderRange As Range Dim oldHeaderRange As Range Dim headerCell As Range Dim colNum As Integer Dim lastRowNew As Long Dim lastColNew As Long Dim cell As Range Dim destCol As Integer

' Set the target worksheets
Set wsNew = ThisWorkbook.Sheets("Month New")
Set wsOld = ThisWorkbook.Sheets("Month Old")

' Clear the existing data in the Month Old sheet
wsOld.Cells.Clear

' Update the month name in cell A1 of the Month Old sheet
wsOld.Range("A1").Value = wsNew.Range("A1").Value

' Get the header range in the new sheet
Set newHeaderRange = wsNew.Range("A1", wsNew.Cells(1, wsNew.Columns.Count).End(xlToLeft))

' Get the header range in the old sheet
Set oldHeaderRange = wsOld.Range("A1", wsOld.Cells(1, wsOld.Columns.Count).End(xlToLeft))

' Find the last row and column in the new sheet
lastRowNew = wsNew.Cells(wsNew.Rows.Count, 1).End(xlUp).Row
lastColNew = wsNew.Cells(1, wsNew.Columns.Count).End(xlToLeft).Column

' Loop through each header in the new sheet
For Each headerCell In newHeaderRange
    ' Find the matching header in the old sheet
    Set cell = oldHeaderRange.Find(What:=headerCell.Value, LookIn:=xlValues, LookAt:=xlWhole)

    ' If a matching header is found, copy the column data
    If Not cell Is Nothing Then
        destCol = cell.Column
    Else
        ' If no matching header is found, use the next available column
        destCol = oldHeaderRange.Cells(1, oldHeaderRange.Columns.Count).End(xlToLeft).Column + 1
        oldHeaderRange.Cells(1, destCol).Value = headerCell.Value
    End If

    ' Copy the column data from the new sheet to the old sheet
    wsNew.Range(wsNew.Cells(2, headerCell.Column), wsNew.Cells(lastRowNew, headerCell.Column)).Copy Destination:=wsOld.Cells(2, destCol)
Next headerCell

' Notify the user of completion
MsgBox "Month Old sheet has been updated successfully.", vbInformation

End Sub

[Viraj-Sanap]

Sub UpdateMonthNew() Dim ws As Worksheet Dim newDataWb As Workbook Dim newDataWs As Worksheet Dim filePath As Variant Dim fileExt As String

' Set the target worksheet
Set ws = ThisWorkbook.Sheets("Month New")

' Prompt the user to select the new data file
filePath = Application.GetOpenFilename(FileFilter:="Excel Files, *.xls; *.xlsx; *.xlsm; *.csv", Title:="Select New Data File")

' Check if the user cancelled the file dialog
If filePath = False Then
    MsgBox "No file selected. Operation cancelled.", vbExclamation
    Exit Sub
End If

' Determine the file extension
fileExt = Right(filePath, Len(filePath) - InStrRev(filePath, "."))

' Open the new data file
Set newDataWb = Workbooks.Open(filePath)

' Assuming the data is in the first sheet of the new data file
Set newDataWs = newDataWb.Sheets(1)

' Clear the existing data in the Month New sheet
ws.Cells.Clear

' Copy new data to the Month New sheet
newDataWs.UsedRange.Copy Destination:=ws.Range("A1")

' Close the new data file
newDataWb.Close SaveChanges:=False

' Notify the user of completion
MsgBox "Month New sheet has been updated successfully.", vbInformation

End Sub

[Viraj-Sanap]

Sub RefreshPivotsAndApplyFilters() Dim ws As Worksheet Dim pt As PivotTable Dim pf As PivotField Dim monthOldValue As Variant Dim monthNewValue As Variant

' Get the month number from B1 in both "Month Old" and "Month New"
monthOldValue = ThisWorkbook.Sheets("Month Old").Range("B1").Value
monthNewValue = ThisWorkbook.Sheets("Month New").Range("B1").Value

' Loop through all worksheets
For Each ws In ThisWorkbook.Worksheets
    ' Loop through all pivot tables in the worksheet
    For Each pt In ws.PivotTables
        ' Refresh the pivot table
        pt.PivotCache.Refresh

        ' Loop through all pivot fields to find and apply the filter for month number
        For Each pf In pt.PivotFields
            On Error Resume Next
            ' Apply filter using monthOldValue if it exists
            pf.ClearAllFilters
            pf.CurrentPage = monthOldValue
            If Err.Number <> 0 Then
                ' If monthOldValue does not apply, try monthNewValue
                pf.ClearAllFilters
                pf.CurrentPage = monthNewValue
            End If
            On Error GoTo 0
        Next pf
    Next pt
Next ws

' Notify the user of completion
MsgBox "All pivot tables have been refreshed and filters applied successfully.", vbInformation

End Sub

[Viraj-Sanap]

=IFERROR(MATCH(TRUE, INDEX(A1:Z1 > 100, 0, MATCH("Joined", A1:Z1, 0) + 1), 0), "")

[Viraj-Sanap]

=IFERROR(MATCH(TRUE, INDEX(INDIRECT(ADDRESS(ROW(),MATCH("Joined",A1:Z1,0)+1) & ":" & ADDRESS(ROW(),COLUMNS(A1:Z1))) > 100, 0), 0), "")

[Viraj-Sanap]

Sub UnpivotTable() Dim ws As Worksheet Dim sourceRange As Range Dim destRange As Range Dim rowCount As Long, colCount As Long Dim i As Long, j As Long Dim lastRow As Long

' Define your worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

' Define your source range (table to unpivot)
' Change the range accordingly
Set sourceRange = ws.Range("A1:D5")

' Get the number of rows and columns in the source range
rowCount = sourceRange.Rows.Count
colCount = sourceRange.Columns.Count

' Define the destination range to start unpivoting
' Assuming starting unpivot output from column F (adjust as needed)
Set destRange = ws.Range("F2")

' Loop through each row in the source range
For i = 2 To rowCount
    ' Loop through each column in the unpivoting range
    For j = 3 To colCount
        ' Write fixed columns (A and B here) to the destination
        destRange.Cells(lastRow + 1, 1).Value = sourceRange.Cells(i, 1).Value
        destRange.Cells(lastRow + 1, 2).Value = sourceRange.Cells(i, 2).Value

        ' Write the unpivoted column name and value to the destination
        destRange.Cells(lastRow + 1, 3).Value = sourceRange.Cells(1, j).Value
        destRange.Cells(lastRow + 1, 4).Value = sourceRange.Cells(i, j).Value

        ' Move to the next row in the destination range
        lastRow = lastRow + 1
    Next j
Next i

MsgBox "Unpivoting complete!"

End Sub

[Viraj-Sanap]

Sub UnpivotTable() Dim ws As Worksheet Dim sourceRange As Range Dim destRange As Range Dim rowCount As Long, colCount As Long Dim i As Long, j As Long Dim lastRow As Long

' Define your worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

' Define your source range (table to unpivot)
' Adjust this range as needed
Set sourceRange = ws.Range("A1:AT" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)

' Get the number of rows and columns in the source range
rowCount = sourceRange.Rows.Count
colCount = sourceRange.Columns.Count

' Define the destination range to start unpivoting
' Assuming starting unpivot output from column AU (adjust as needed)
Set destRange = ws.Range("AU2")

' Initialize lastRow for the destination range
lastRow = 1

' Loop through each row in the source range
For i = 2 To rowCount
    ' Loop through each column to be unpivoted (F to AT)
    For j = 6 To colCount
        ' Copy fixed columns (A to E) to the destination
        destRange.Cells(lastRow, 1).Value = sourceRange.Cells(i, 1).Value ' Column A
        destRange.Cells(lastRow, 2).Value = sourceRange.Cells(i, 2).Value ' Column B
        destRange.Cells(lastRow, 3).Value = sourceRange.Cells(i, 3).Value ' Column C
        destRange.Cells(lastRow, 4).Value = sourceRange.Cells(i, 4).Value ' Column D
        destRange.Cells(lastRow, 5).Value = sourceRange.Cells(i, 5).Value ' Column E

        ' Copy the month (column headers F to AT) as "Month" to the destination
        destRange.Cells(lastRow, 6).Value = sourceRange.Cells(1, j).Value ' Month

        ' Copy the value (PnL) to the destination
        destRange.Cells(lastRow, 7).Value = sourceRange.Cells(i, j).Value ' PnL

        ' Move to the next row in the destination range
        lastRow = lastRow + 1
    Next j
Next i

MsgBox "Unpivoting complete!"

End Sub

[Viraj-Sanap]

Sub UnpivotTable() Dim ws As Worksheet Dim sourceRange As Range Dim destRange As Range Dim rowCount As Long, colCount As Long Dim i As Long, j As Long Dim lastRow As Long

' Define your worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

' Define your source range (table to unpivot)
' Adjust this range as needed
Set sourceRange = ws.Range("A1:AT" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)

' Get the number of rows and columns in the source range
rowCount = sourceRange.Rows.Count
colCount = sourceRange.Columns.Count

' Define the destination range to start unpivoting
' Assuming starting unpivot output from column AU (adjust as needed)
Set destRange = ws.Range("AU2")

' Initialize lastRow for the destination range
lastRow = 1

' Loop through each row in the source range
For i = 2 To rowCount
    ' Loop through each column to be unpivoted (F to AT)
    For j = 6 To colCount
        ' Copy fixed columns (A to E) to the destination
        sourceRange.Cells(i, 1).Copy
        destRange.Cells(lastRow, 1).PasteSpecial Paste:=xlPasteAll

        sourceRange.Cells(i, 2).Copy
        destRange.Cells(lastRow, 2).PasteSpecial Paste:=xlPasteAll

        sourceRange.Cells(i, 3).Copy
        destRange.Cells(lastRow, 3).PasteSpecial Paste:=xlPasteAll

        sourceRange.Cells(i, 4).Copy
        destRange.Cells(lastRow, 4).PasteSpecial Paste:=xlPasteAll

        sourceRange.Cells(i, 5).Copy
        destRange.Cells(lastRow, 5).PasteSpecial Paste:=xlPasteAll

        ' Copy the month (column headers F to AT) as "Month" to the destination
        sourceRange.Cells(1, j).Copy
        destRange.Cells(lastRow, 6).PasteSpecial Paste:=xlPasteAll

        ' Copy the value (PnL) to the destination
        sourceRange.Cells(i, j).Copy
        destRange.Cells(lastRow, 7).PasteSpecial Paste:=xlPasteAll

        ' Move to the next row in the destination range
        lastRow = lastRow + 1
    Next j
Next i

' Clear the clipboard (optional)
Application.CutCopyMode = False

MsgBox "Unpivoting complete with formatting preserved!"

End Sub

[Viraj-Sanap]

Sub CreateFolders() Dim FolderPath As String Dim FolderName As String Dim LastRow As Long Dim i As Long

' Set the parent folder path where the new folders will be created
FolderPath = "C:\Your\Folder\Path\" ' Change this to your desired path

' Find the last row with data in column A
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

' Loop through each cell in column A
For i = 1 To LastRow
    FolderName = Cells(i, 1).Value
    ' Check if folder name is not empty
    If FolderName <> "" Then
        ' Create folder if it doesn't already exist
        If Dir(FolderPath & FolderName, vbDirectory) = "" Then
            MkDir FolderPath & FolderName
        End If
    End If
Next i

End Sub

[Viraj-Sanap]

Sub CreateHierarchy() Dim ws As Worksheet Dim lastRow As Long Dim colL As Long Dim empCol As Range Dim supCol As Range Dim row As Long Dim currentEmp As String Dim currentSup As String Dim level As Long Dim found As Range

' Set the worksheet and find the last row
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the name of your worksheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Set employee column (A) and supervisor column (B)
Set empCol = ws.Range("A2:A" & lastRow)
Set supCol = ws.Range("B2:B" & lastRow)

' Start hierarchy columns from column C
colL = 3 ' Column C for L1 (Employee)

' Add headers for levels
ws.Cells(1, colL).Value = "L1 (Employee)"
ws.Cells(1, colL + 1).Value = "L2 (Supervisor)"
ws.Cells(1, colL + 2).Value = "L3 (Supervisor's Supervisor)"
ws.Cells(1, colL + 3).Value = "L4"

' Loop through each employee
For row = 2 To lastRow
    currentEmp = ws.Cells(row, 1).Value ' Employee name
    currentSup = ws.Cells(row, 2).Value ' Supervisor name
    ws.Cells(row, colL).Value = currentEmp ' L1 is the employee himself

    level = 1

    ' Loop through each level of supervisor hierarchy
    Do While currentSup <> ""
        level = level + 1
        ws.Cells(row, colL + level - 1).Value = currentSup ' Fill supervisor in L2, L3, etc.

        ' Find the supervisor's supervisor in employee column
        Set found = empCol.Find(currentSup, LookIn:=xlValues, LookAt:=xlWhole)

        If Not found Is Nothing Then
            ' If found, set current supervisor to the found supervisor
            currentSup = ws.Cells(found.Row, 2).Value
        Else
            ' If not found, exit the loop
            currentSup = ""
        End If
    Loop
Next row

End Sub

[Viraj-Sanap]

Sub CreateDynamicHierarchy() Dim ws As Worksheet Dim lastRow As Long Dim colL As Long Dim empCol As Range Dim supCol As Range Dim row As Long Dim currentEmp As String Dim currentSup As String Dim level As Long Dim found As Range

' Set the worksheet and find the last row
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the name of your worksheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Set employee column (A) and supervisor column (B)
Set empCol = ws.Range("A2:A" & lastRow)
Set supCol = ws.Range("B2:B" & lastRow)

' Start hierarchy columns from column C
colL = 3 ' Column C for L1 (Employee)

' Add header for L1 (Employee)
ws.Cells(1, colL).Value = "L1 (Employee)"

' Loop through each employee
For row = 2 To lastRow
    currentEmp = ws.Cells(row, 1).Value ' Employee name
    currentSup = ws.Cells(row, 2).Value ' Supervisor name
    ws.Cells(row, colL).Value = currentEmp ' L1 is the employee himself

    level = 1

    ' Loop through each level of supervisor hierarchy
    Do While currentSup <> ""
        level = level + 1

        ' Add header for the next level dynamically
        ws.Cells(1, colL + level - 1).Value = "L" & level

        ' Fill supervisor at the current level (L2, L3, etc.)
        ws.Cells(row, colL + level - 1).Value = currentSup

        ' Find the supervisor's supervisor in employee column
        Set found = empCol.Find(currentSup, LookIn:=xlValues, LookAt:=xlWhole)

        If Not found Is Nothing Then
            ' If found, set current supervisor to the found supervisor
            currentSup = ws.Cells(found.Row, 2).Value
        Else
            ' If not found, exit the loop
            currentSup = ""
        End If
    Loop
Next row

End Sub

[Viraj-Sanap]

Sub GetFullHierarchy() Dim ws As Worksheet Dim empCol As Range Dim supCol As Range Dim lastRow As Long Dim hierarchy As Collection Dim supervisor As String Dim emp As Range Dim result As String

' Set the worksheet and find the last row
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the name of your worksheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Set employee and supervisor columns
Set empCol = ws.Range("A2:A" & lastRow)
Set supCol = ws.Range("B2:B" & lastRow)

' Prompt for the supervisor's name
supervisor = InputBox("Enter the name of the supervisor:")

' Initialize collection to store hierarchy
Set hierarchy = New Collection

' Call recursive function to find hierarchy
Call FindHierarchy(supervisor, empCol, supCol, hierarchy)

' Compile the result for output
If hierarchy.Count > 0 Then
    result = "Employees under " & supervisor & ":" & vbNewLine
    For Each emp In hierarchy
        result = result & emp & vbNewLine
    Next emp
Else
    result = "No employees found under " & supervisor
End If

' Output the result in a message box
MsgBox result

End Sub

' Recursive function to find the full hierarchy Sub FindHierarchy(supervisor As String, empCol As Range, supCol As Range, hierarchy As Collection) Dim emp As Range Dim sup As Range Dim found As Range

' Loop through supervisor column to find all employees reporting to the given supervisor
For Each sup In supCol
    If sup.Value = supervisor Then
        Set found = sup.Offset(0, -1) ' Find the corresponding employee in the employee column
        hierarchy.Add found.Value ' Add employee to the hierarchy collection

        ' Recursively find employees under this employee
        Call FindHierarchy(found.Value, empCol, supCol, hierarchy)
    End If
Next sup

End Sub

[Viraj-Sanap]

Sub FindEmployeesBySupervisor() Dim ws As Worksheet Dim wsResult As Worksheet Dim lastRow As Long Dim lastCol As Long Dim searchName As String Dim row As Long Dim col As Long Dim resultRow As Long Dim empName As String Dim found As Boolean

' Set the worksheet where the hierarchy is stored
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the name of your worksheet

' Set the result worksheet
On Error Resume Next
Set wsResult = ThisWorkbook.Sheets("Sheet2")
If wsResult Is Nothing Then
    Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsResult.Name = "Sheet2"
End If
On Error GoTo 0

' Clear any existing data in Sheet2
wsResult.Cells.Clear

' Get the last row and column of the hierarchy table
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

' Get the supervisor name to search for
searchName = InputBox("Enter the supervisor name to search for:")

' Set the starting row for results on Sheet2
resultRow = 1

' Loop through all rows and columns to find the supervisor
For row = 2 To lastRow
    found = False
    empName = ws.Cells(row, 3).Value ' Get the employee name from L1 (Column C)

    ' Check all columns from L2 onward for the search name
    For col = 4 To lastCol ' Assuming L2 starts from column D (4th column)
        If ws.Cells(row, col).Value = searchName Then
            found = True
            Exit For ' Exit the inner loop once we find the supervisor
        End If
    Next col

    ' If found, write the employee name from L1 to the result sheet
    If found Then
        wsResult.Cells(resultRow, 1).Value = empName
        resultRow = resultRow + 1
    End If
Next row

' Check if any results were found
If resultRow = 1 Then
    MsgBox "No employees found under the supervisor '" & searchName & "'.", vbExclamation
Else
    MsgBox "Employees reporting under '" & searchName & "' have been listed in Sheet2.", vbInformation
End If

End Sub

[Viraj-Sanap]

Sub FindEmployeesBySupervisor() Dim ws As Worksheet Dim wsResult As Worksheet Dim lastRow As Long Dim lastCol As Long Dim searchName As String Dim row As Long Dim col As Long Dim resultRow As Long Dim empName As String Dim found As Boolean Dim dict As Object

' Set the worksheet where the hierarchy is stored
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the name of your worksheet

' Set the result worksheet
On Error Resume Next
Set wsResult = ThisWorkbook.Sheets("Sheet2")
If wsResult Is Nothing Then
    Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsResult.Name = "Sheet2"
End If
On Error GoTo 0

' Clear any existing data in Sheet2
wsResult.Cells.Clear

' Get the last row and column of the hierarchy table
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

' Get the supervisor name to search for
searchName = InputBox("Enter the supervisor name to search for:")

' Set the starting row for results on Sheet2
resultRow = 1

' Initialize the dictionary to store unique employee names
Set dict = CreateObject("Scripting.Dictionary")

' Loop through all rows and columns to find the supervisor
For row = 2 To lastRow
    found = False
    empName = ws.Cells(row, 3).Value ' Get the employee name from L1 (Column C)

    ' Check all columns from L2 onward for the search name
    For col = 4 To lastCol ' Assuming L2 starts from column D (4th column)
        If ws.Cells(row, col).Value = searchName Then
            found = True
            Exit For ' Exit the inner loop once we find the supervisor
        End If
    Next col

    ' If found, write the employee name from L1 to the result sheet if it's not already in the dictionary
    If found Then
        If Not dict.Exists(empName) Then
            dict.Add empName, True ' Add to the dictionary to avoid duplicates
            wsResult.Cells(resultRow, 1).Value = empName
            resultRow = resultRow + 1
        End If
    End If
Next row

' Check if any results were found
If resultRow = 1 Then
    MsgBox "No employees found under the supervisor '" & searchName & "'.", vbExclamation
Else
    MsgBox "Employees reporting under '" & searchName & "' have been listed in Sheet2.", vbInformation
End If

End Sub

[Viraj-Sanap]

Sub GenerateFullHierarchyForAllSupervisors_IndividualRows() Dim ws As Worksheet Dim wsResult As Worksheet Dim lastRow As Long Dim lastCol As Long Dim empName As String Dim row As Long Dim col As Long Dim resultRow As Long Dim dict As Object Dim hierarchy As Collection Dim supervisee As Range

' Set the worksheet where the hierarchy is stored
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the name of your worksheet

' Set the result worksheet
On Error Resume Next
Set wsResult = ThisWorkbook.Sheets("Sheet2")
If wsResult Is Nothing Then
    Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsResult.Name = "Sheet2"
End If
On Error GoTo 0

' Clear any existing data in Sheet2
wsResult.Cells.Clear

' Get the last row and column of the hierarchy table
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

' Set the starting row for results on Sheet2
resultRow = 1

' Loop through each employee in column 1 (L1)
For row = 2 To lastRow
    empName = ws.Cells(row, 1).Value ' Get the employee name from L1 (Column A)

    ' Initialize collection to store the supervisee hierarchy
    Set hierarchy = New Collection

    ' Call the recursive function to get the full hierarchy for the employee
    Call FindHierarchyForEmployee(empName, ws, hierarchy, lastRow, lastCol)

    ' If the employee has supervisees, write to the result sheet
    If hierarchy.Count > 0 Then
        ' Write each supervisee to a separate row in Sheet2
        For Each supervisee In hierarchy
            wsResult.Cells(resultRow, 1).Value = empName ' Supervisor name
            wsResult.Cells(resultRow, 2).Value = supervisee ' Individual Supervisee
            resultRow = resultRow + 1
        Next supervisee
    End If
Next row

MsgBox "Full hierarchy has been generated in Sheet2 with individual supervisees listed.", vbInformation

End Sub

' Recursive function to find the full hierarchy for a given employee Sub FindHierarchyForEmployee(supervisor As String, ws As Worksheet, hierarchy As Collection, lastRow As Long, lastCol As Long) Dim row As Long Dim col As Long Dim empName As String

' Loop through each row and check if the supervisor is found in any column from L2 onward
For row = 2 To lastRow
    For col = 2 To lastCol ' Start from column L2 (second column)
        If ws.Cells(row, col).Value = supervisor Then
            empName = ws.Cells(row, 1).Value ' Get the employee name from L1 (Column A)

            ' If the employee is not already in the hierarchy, add them and continue searching
            If Not IsInCollection(hierarchy, empName) Then
                hierarchy.Add empName
                ' Recursively find supervisees of this employee
                Call FindHierarchyForEmployee(empName, ws, hierarchy, lastRow, lastCol)
            End If
        End If
    Next col
Next row

End Sub

' Helper function to check if an item exists in the collection Function IsInCollection(coll As Collection, item As Variant) As Boolean Dim var As Variant On Error Resume Next var = coll(item) If Err.Number = 0 Then IsInCollection = True Else IsInCollection = False End If On Error GoTo 0 End Function

[Viraj-Sanap]

Sub GenerateHierarchyForAllEmployees() Dim ws As Worksheet Dim wsResult As Worksheet Dim lastRow As Long Dim lastCol As Long Dim empName As String Dim row As Long Dim col As Long Dim resultRow As Long Dim hierarchy As Collection Dim supervisee As Variant Dim dict As Object

' Set the worksheet where the hierarchy is stored
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the name of your worksheet

' Set the result worksheet
On Error Resume Next
Set wsResult = ThisWorkbook.Sheets("Sheet2")
If wsResult Is Nothing Then
    Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsResult.Name = "Sheet2"
End If
On Error GoTo 0

' Clear any existing data in Sheet2
wsResult.Cells.Clear

' Get the last row and column of the hierarchy table
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

' Set the starting row for results on Sheet2
resultRow = 1

' Initialize the dictionary to store unique supervisees
Set dict = CreateObject("Scripting.Dictionary")

' Loop through each employee in column 1 (L1) and find their hierarchy
For row = 2 To lastRow
    empName = ws.Cells(row, 1).Value ' Get the employee name from Column 1

    ' Initialize collection to store the supervisee hierarchy
    Set hierarchy = New Collection

    ' Call the recursive function to get the full hierarchy for the employee
    Call FindHierarchyForEmployee_Updated(empName, ws, hierarchy, lastRow, lastCol)

    ' If the employee has supervisees, write to the result sheet
    If hierarchy.Count > 0 Then
        ' Write each supervisee to a separate row in Sheet2
        For Each supervisee In hierarchy
            If Not dict.Exists(empName & "|" & supervisee) Then
                dict.Add empName & "|" & supervisee, True
                wsResult.Cells(resultRow, 1).Value = empName ' Supervisor name
                wsResult.Cells(resultRow, 2).Value = supervisee ' Individual Supervisee
                resultRow = resultRow + 1
            End If
        Next supervisee
    End If
Next row

MsgBox "Hierarchy for all employees has been generated in Sheet2 with individual supervisees listed.", vbInformation

End Sub

' Recursive function to find the full hierarchy for a given employee Sub FindHierarchyForEmployee_Updated(supervisor As String, ws As Worksheet, hierarchy As Collection, lastRow As Long, lastCol As Long) Dim row As Long Dim col As Long Dim empName As String

' Loop through each row and check if the supervisor is found in any column from L2 onward
For row = 2 To lastRow
    For col = 2 To lastCol ' Start from column L2 (second column onwards for supervisors)
        If ws.Cells(row, col).Value = supervisor Then
            empName = ws.Cells(row, 1).Value ' Get the employee name from L1 (Column A)

            ' If the employee is not already in the hierarchy, add them and continue searching
            If Not IsInCollection(hierarchy, empName) Then
                hierarchy.Add empName
                ' Recursively find supervisees of this employee
                Call FindHierarchyForEmployee_Updated(empName, ws, hierarchy, lastRow, lastCol)
            End If
        End If
    Next col
Next row

End Sub

' Helper function to check if an item exists in the collection Function IsInCollection(coll As Collection, item As Variant) As Boolean Dim var As Variant On Error Resume Next var = coll(item) If Err.Number = 0 Then IsInCollection = True Else IsInCollection = False End If On Error GoTo 0 End Function

[Viraj-Sanap]

Sub GenerateHierarchyForFixedRange() Dim wsSource As Worksheet Dim wsResult As Worksheet Dim wsNames As Worksheet Dim lastRow As Long Dim lastCol As Long Dim startRow As Long Dim endRow As Long Dim resultRow As Long Dim nameRow As Long Dim empName As String Dim dict As Object

' Set the worksheets
Set wsSource = ThisWorkbook.Sheets("Sheet1") ' The worksheet with the hierarchy
Set wsNames = ThisWorkbook.Sheets("Sheet3") ' The worksheet with the names list
Set wsResult = ThisWorkbook.Sheets("Sheet2") ' The worksheet to output results

' Clear any existing data in Sheet2
wsResult.Cells.Clear

' Get the last row and column of the hierarchy table
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column

' Define the fixed range for names
startRow = 1 ' Starting row in Sheet3
endRow = 5 ' Ending row in Sheet3

' Set the starting row for results on Sheet2
resultRow = 1

' Initialize the dictionary to store unique results
Set dict = CreateObject("Scripting.Dictionary")

' Loop through each name in Sheet3 (A1 to A5)
For nameRow = startRow To endRow
    empName = wsNames.Cells(nameRow, 1).Value ' Get the employee name from Sheet3

    ' Call the existing function to get the hierarchy for the employee
    Call FindEmployeesBySupervisor(wsSource, empName, wsResult, resultRow, dict)
Next nameRow

MsgBox "Hierarchy for the specified range of employees has been generated in Sheet2.", vbInformation

End Sub

' Function to find employees by supervisor and output results to Sheet2 Sub FindEmployeesBySupervisor(wsSource As Worksheet, searchName As String, wsResult As Worksheet, ByRef resultRow As Long, dict As Object) Dim lastRow As Long Dim lastCol As Long Dim row As Long Dim col As Long Dim empName As String Dim found As Boolean

' Get the last row and column of the hierarchy table
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column

' Loop through all rows to find the supervisor
For row = 2 To lastRow
    found = False
    empName = wsSource.Cells(row, 1).Value ' Get the employee name from L1 (Column A)

    ' Check all columns from L2 onward for the search name
    For col = 2 To lastCol ' Assuming L2 starts from column B (2nd column onward)
        If wsSource.Cells(row, col).Value = searchName Then
            found = True
            Exit For ' Exit the inner loop once we find the supervisor
        End If
    Next col

    ' If found, write the employee name from L1 to the result sheet if it's not already in the dictionary
    If found Then
        If Not dict.Exists(empName) Then
            dict.Add empName, True ' Add to the dictionary to avoid duplicates
            wsResult.Cells(resultRow, 1).Value = searchName ' Supervisor name
            wsResult.Cells(resultRow, 2).Value = empName ' Supervisee
            resultRow = resultRow + 1
        End If
    End If
Next row

End Sub

[Viraj-Sanap]

Function Levenshtein(s1 As String, s2 As String) As Integer Dim x As Integer, y As Integer, s1len As Integer, s2len As Integer Dim matrix() As Integer

s1len = Len(s1)
s2len = Len(s2)

ReDim matrix(0 To s1len, 0 To s2len)

For x = 0 To s1len
    matrix(x, 0) = x
Next x

For y = 0 To s2len
    matrix(0, y) = y
Next y

For x = 1 To s1len
    For y = 1 To s2len
        If Mid(s1, x, 1) = Mid(s2, y, 1) Then
            matrix(x, y) = matrix(x - 1, y - 1)
        Else
            matrix(x, y) = 1 + Application.WorksheetFunction.Min(matrix(x - 1, y - 1), matrix(x - 1, y), matrix(x, y - 1))
        End If
    Next y
Next x

Levenshtein = matrix(s1len, s2len)

End Function

[Viraj-Sanap]

Sub DeleteUnfilteredRows() Dim ws As Worksheet Dim rng As Range

' Set the worksheet
Set ws = ActiveSheet

' Ensure that a filter is applied
If ws.AutoFilterMode = False Then
    MsgBox "Please apply a filter first."
    Exit Sub
End If

' Define the range of visible rows
On Error Resume Next ' In case no visible rows
Set rng = ws.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

' If there are no visible rows, show a message and exit
If rng Is Nothing Then
    MsgBox "No visible rows found."
    Exit Sub
End If

' Delete the entire range except the visible rows
ws.AutoFilter.Range.Offset(1, 0).Resize(ws.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete

End Sub

[Viraj-Sanap]

Sub KeepOnlyVisibleRows() Dim ws As Worksheet Dim tempSheet As Worksheet Dim visibleRange As Range Dim lastRow As Long

' Set the current worksheet
Set ws = ActiveSheet

' Ensure that a filter is applied
If ws.AutoFilterMode = False Then
    MsgBox "Please apply a filter first."
    Exit Sub
End If

' Define the range of visible rows (excluding the header)
On Error Resume Next
Set visibleRange = ws.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

' If no visible rows are found, exit the sub
If visibleRange Is Nothing Then
    MsgBox "No visible rows found."
    Exit Sub
End If

' Create a temporary sheet
Set tempSheet = Sheets.Add(After:=Sheets(Sheets.Count))
tempSheet.Name = "TempSheet"

' Copy visible rows (including header) to the temporary sheet
visibleRange.Copy Destination:=tempSheet.Range("A1")

' Clear all content from the original sheet
ws.UsedRange.Clear

' Paste the visible rows back to the original sheet
tempSheet.UsedRange.Copy Destination:=ws.Range("A1")

' Delete the temporary sheet
Application.DisplayAlerts = False
tempSheet.Delete
Application.DisplayAlerts = True

MsgBox "Unfiltered rows removed and only filtered rows are retained."

End Sub

[Viraj-Sanap]

Sub CheckNewOrExisting() Dim wsOld As Worksheet Dim wsNew As Worksheet Dim lastRowOld As Long, lastRowNew As Long Dim oldConcat As Range, newConcat As Range Dim i As Long

' Set old and new sheets
Set wsOld = Worksheets("Old")
Set wsNew = Worksheets("New")

' Find the last rows in both sheets
lastRowOld = wsOld.Cells(wsOld.Rows.Count, 1).End(xlUp).Row
lastRowNew = wsNew.Cells(wsNew.Rows.Count, 1).End(xlUp).Row

' Concatenate column 1 and column 2 in the old sheet into column 3
For i = 1 To lastRowOld
    wsOld.Cells(i, 3).Value = wsOld.Cells(i, 1).Value & wsOld.Cells(i, 2).Value
Next i

' Concatenate column 1 and column 2 in the new sheet into column 3
For i = 1 To lastRowNew
    wsNew.Cells(i, 3).Value = wsNew.Cells(i, 1).Value & wsNew.Cells(i, 2).Value
Next i

' Create a VLOOKUP to check if concatenated value in new sheet exists in the old sheet
For i = 1 To lastRowNew
    On Error Resume Next ' To avoid error in case VLOOKUP fails
    If Not IsError(Application.VLookup(wsNew.Cells(i, 3).Value, wsOld.Range("C1:C" & lastRowOld), 1, False)) Then
        wsNew.Cells(i, 4).Value = "Existing"
    Else
        wsNew.Cells(i, 4).Value = "New"
    End If
    On Error GoTo 0
Next i

' Delete the old sheet
Application.DisplayAlerts = False
wsOld.Delete
Application.DisplayAlerts = True

MsgBox "Process Complete: New or Existing check done, and old sheet deleted."

End Sub