Tricky Vba to extract few data with condition and few randomly - vba

I have a file with one sheet named as Audit file. It has multiple columns until column Z
The first column(A) has auditors name column (C) has regions and column (X) has decisions(Valid, invalid, correct incorrect and dropdown lists)
First row has headers.
Each person works on multiple regions,
I need to extract 27 rows for each person's each region and paste it in a new sheet and name it Verification (example: person A works on UK, US, IND,etc, similarly person B works on UK, SD, IS, etc, The code should extract for person A region UK 27 rows, For person A US region 27 rows, Person A IND region 27 rows, then move to the next person B UK region #7 rows and so on....)
In 27 rows for each persons each region, all the rows containing Valid in Column X must be included and the remaining rows can be randomly selected excluding the Valid values in column X.
How I do Manually is, first filter person A, then filter Region UK then Filter Valid decision, copy everything and paste in sheet Verification, the remove the filter and select the remaining rows randomly and paste them in Verifivation sheet, then I do it for next region, once Person A's regions are completed I move to Person B, and so on.
Option Explicit
Public gcolNames As Collection
Public Const kiPULLQTY = 27
Public Const kiColREG = 3
Public giMarker As Long
Public rng As Range
Public Sub RunData()
LoadNames
MakeResults
End Sub
Private Sub AuditList()
Dim iRows As Long
On Error Resume Next
Sheets("Results").Delete
Sheets("Auditors").Delete
Sheets("Data").Select
'Sheets.Add
'ActiveSheet.Name = "results"
Sheets.Add
ActiveSheet.Name = "auditors"
Sheets("Data").Select
Columns("A:A").Select
Selection.Copy
Sheets("auditors").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
iRows = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Range("$A$1:$A$" & iRows).RemoveDuplicates Columns:=1, Header:=xlYes
LoadNames
End Sub
'load the auditors
Private Sub LoadNames()
Dim sName As String
On Error Resume Next
Set gcolNames = New Collection
Sheets("auditors").Select
Range("A2").Select
While ActiveCell.Value <> ""
sName = ActiveCell.Value
gcolNames.Add sName, sName
ActiveCell.Offset(1, 0).Select 'next row
Wend
Sheets("Data").Select
Range("A1").Select
End Sub
Private Sub MakeResults()
Dim i As Integer
Dim vName
Sheets("Data").Select
Range("A1").Select
For i = 1 To gcolNames.Count
vName = gcolNames(i)
Set rng = ActiveSheet.UsedRange
Selection.AutoFilter
rng.AutoFilter Field:=1, Criteria1:=vName
GoSub PostResults
Sheets("Data").Select
Selection.AutoFilter 'filter off
Next
Sheets("Data").Select
Selection.AutoFilter
Exit Sub
Set rng = ActiveSheet.UsedRange
rng.Copy
Sheets.Add
ActiveSheet.Name = vName
Sheets(vName).Activate
ActiveCell.PasteSpecial xlPasteAll
Application.CutCopyMode = False
Return
End Sub
I have this code gathered from online sources, but it doesn't work the code only paste all the values in seperate sheet based on auditor names. it doesn't extract 27 columns even for each person.

Related

Sorting a Large Excel Spreadsheet by Date - Fails on 3rd Iteration

I am new to VBA as a language, and I'm having issues sorting a large spreadsheet. The sheet is roughly 400,000 rows by 8 columns. The relevant data begins on row 5. In Column C, I changed the format of the date and rounded it down to give a single integer representing the day.
The goal is to find where the data changes days, and cut and paste all of that day's data to a seperate tab. The code I have written successfully does this for the first 2 days, but the 3rd iteration and beyond will not work properly. I have used a color code (blue) to represent the last row for each day, and I'm using this color change as my loop condition. The 3rd loop ignores the 1st color change and instead cuts and pastes 2 day's worth of data, and the 4th loop moves 3 days.
Would there be a more efficient way to move each day's data to a new tab? Each day represents 28800 rows by 6 columns. It should be noted that an additional macro is run before this in order to simply organize the raw data. The portion of the code giving me issues are the loops following the "Sort the data by date" comment.
Any help would be greatly appreciated! Thanks in advance. Attached is my code and a sample of the data
Sub HOBO_Split_v2()
'Before this code can be run, you must run "Hobo_Organize" 1 time. Press 'Ctrl + Shift + O' to do this
'The purpose of this code is to separate the hobo data by day. Weekends and evenings will be removed.
'This will create smaller data sets, which allows for easier data manipulation
Application.ScreenUpdating = False
'Find the last row
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
'Set the known parameters
Dim days As Range
Set days = Worksheets("Full Data Set").Range("C5:C" & Lastrow)
Dim daychanges As String
daychanges = 0
'Maximum of 3 weeks of data, 21 different sheets
Dim sheetnum(1 To 21) As Integer
For i = 1 To 21
sheetnum(i) = i
Next i
'Loop through the day index (Col C), counting the number of day changes
For Each cell In days
If cell.Value <> cell.Offset(1).Value Then
cell.Interior.ColorIndex = 37
daychanges = daychanges + 1
End If
Next cell
'Add new sheets for each day and rename the sheets
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Day 1"
For i = 2 To daychanges
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Day " & sheetnum(i)
Next i
Sheets("Full Data Set").Select
'Sort the data by date
For Each cell In days
If cell.Interior.ColorIndex = 37 Then
cell.Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Worksheets(Worksheets.Count).Select
ActiveSheet.Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Move Before:=Sheets("Full Data Set")
Sheets("Full Data Set").Select
Range("C4").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select
Set days = Selection
End If
Next cell
Application.ScreenUpdating = True
End Sub
Example of the data
I'd not pass through any cell coloring and use RemoveDuplicates() method of Range object as like follows:
Option Explicit
Sub HOBO_Split_v2()
Dim datesRng As Range, dataRng As Range, cell As Range
Dim iDay As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Full Data Set")
Set datesRng = .Range("C5", .Cells(.Rows.Count, 3).End(xlUp)) '<--| set dates range
Set dataRng = datesRng.offset(-1).Resize(datesRng.Rows.Count + 1, 6) '<--| set data range as dates one extended to next 5 columns
With datesRng.offset(, .UsedRange.Columns.Count) '<--| use a helper column out of current used range
.value = datesRng.value '<--| copy dates value in helper column
.RemoveDuplicates Columns:=Array(1) '<--| remove duplicates and have only unique values in helper column
For Each cell In .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) '<--| iterate through remaining (unique) day values in helper column
iDay = iDay + 1 '<--| update "current day" counter
dataRng.AutoFilter Field:=1, Criteria1:=Format(cell, "#.00") '<--| filter data by "current day", format the criteria as the actual column C cells format
dataRng.offset(1).Resize(dataRng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=SetWorkSheet(ThisWorkbook, "Day " & iDay).Range("B2") '<--| copy filtered data and paste the into "current day" corresponding sheet
Next cell
.Parent.AutoFilterMode = False '<--| remove autofilter
.Clear '<--| clear helper column
End With
End With
Application.ScreenUpdating = True
End Sub
Function SetWorkSheet(wb As Workbook, SheetName As String) As Worksheet
On Error Resume Next
Set SetWorkSheet = wb.Worksheets(SheetName)
On Error GoTo 0
If SetWorkSheet Is Nothing Then
Set SetWorkSheet = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
SetWorkSheet.Name = SheetName
Else
SetWorkSheet.UsedRange.Clear '<--| clear preceeding values in already existent sheet
End If
End Function
There is no need to iterate over the list twice. GetWorkSheet create the new worksheets for you if they don't exist and handle any errors.
Sub HOBO_Split_v2()
Application.ScreenUpdating = False
Dim cell As Range, days As Range
Dim lFirstRow As Long, Lastrow As Long
Dim SheetName As String
Dim ws As Worksheet
With Sheets("Full Data Set")
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
Set days = .Range("C5:C" & Lastrow)
For Each cell In days
If c.Text <> SheetName Or c.Row = Lastrow Then
If lFirstRow > 0 Then
Set ws = getWorkSheet(SheetName)
.Range("A" & lFirstRow, "A" & cell.Row).EntireRow.Copy ws.Range("A1")
End If
SheetName = c.Text
lFirstRow = i
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getWorkSheet(SheetName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(SheetName)
If ws Is Nothing Then
Set ws = Worksheets.Add(after:=ActiveSheet)
ws.Name = SheetName
End If
On Error GoTo 0
Set getWorkSheet = ws
End Function

Offsetting a Range in VBA

I have the following code, which copies and pastes values from one sheet to another, depending on the number of rows and columns. The code works great when copying each value one-by-one. However, the dataset that I am currently working with will always have values in rows 11 to 110 (100 values total), with only the column changing.
Hence, how can I alter the lines of code with the arrows (<--) so that it always copies rows 11 to 110, offsetting only the column number?
Option Explicit
Sub Transpose_Lapse_LevelTrend()
Dim ws As Worksheet
Dim i, k, multiple As Integer
Dim rawrowcount As Long
Dim rawcolcount As Long
'Define variables for the below-noted code
For i = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i).Name = "Q_Sheet7.1" Then
ActiveWorkbook.Sheets(i).Delete
End If
Next i
'Delete Worksheet if already existing for respective tab
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Q_Sheet7.1"
ws.Range("A1").Value = "Year"
ws.Range("B1").Value = "Product"
ws.Range("C1").Value = "Cashflow"
End With
With ThisWorkbook.Sheets("7.1")
.Range("A:A").Delete
rawrowcount = WorksheetFunction.CountA(.Range("A:A")) - WorksheetFunction.CountA(.Range("A1:A10")) - 1
rawcolcount = .Cells(10, Columns.Count).End(xlToLeft).Column - 2
End With
'Count the number of rows and columns to determine how many the number of iterations
'for the next set of code
Application.ScreenUpdating = False
'Do not update screen while executing code
For i = 1 To rawcolcount
multiple = rawrowcount * (i - 1)
For k = 1 To rawrowcount
'Sheets("7.1").Activate <--
'ActiveSheet.Range("A9").Select <--
'Selection.Offset(k + 1, 0).Select <--
'Selection.Copy <--
'Sheets("Q_Sheet7.1").Activate <--
'ActiveSheet.Range("A1").Select <--
'Selection.Offset(k + multiple, 0).Select <--
'ActiveSheet.Paste <--
'Copy and paste Years 1 to 100
Sheets("7.1").Activate
ActiveSheet.Range("A9").Select
Selection.Offset(k + 1, i).Select
Selection.Copy
Sheets("Q_Sheet7.1").Activate
ActiveSheet.Range("A1").Select
Selection.Offset(k + multiple, 2).Select
ActiveSheet.Paste
'Copy and paste the Cashflow for Years 1 to 100 for
'each Product
Next k
'Repeat for each Product Type
Sheets("7.1").Activate
ActiveSheet.Range("A9").Select
Selection.Offset(2, 0).Select
Selection.Copy
Sheets("Q_Sheet7.1").Activate
ActiveSheet.Range("A1").Select
Selection.Offset(multiple + 1, 0).Select
ActiveSheet.Paste
'Copy & paste the Year for each respective Cashflow
'Sheets("7.1").Activate
'ActiveSheet.Range("B7").Select
'Selection.Offset(0, i).Select
'Selection.Copy
'Sheets("Q_Sheet7.1").Activate
'ActiveSheet.Range("A1").Select
'Selection.Offset(multiple + 1, 1).Select
'ActiveSheet.Paste
'Copy & paste Region for the respective Cashflow
Sheets("7.1").Activate
ActiveSheet.Range("A9").Select
Selection.Offset(1, i).Select
Selection.Copy
Sheets("Q_Sheet7.1").Activate
ActiveSheet.Range("A1").Select
Selection.Offset(multiple + 1, 1).Select
ActiveSheet.Paste
'Copy & paste the Product for each respective Cashflow
'Sheets("7.1").Activate
'ActiveSheet.Range("B8").Select
'Selection.Offset(0, i).Select
'Selection.Copy
'Sheets("Q_Sheet7.1").Activate
'ActiveSheet.Range("A1").Select
'Selection.Offset(multiple + 1, 3).Select
'ActiveSheet.Paste
'Copy & paste Risk for the respective Cashflow
ActiveSheet.Range(ActiveSheet.Cells(multiple + 2, 1), ActiveSheet.Cells(multiple + 2, 2)).Select
Selection.AutoFill Destination:=Range(ActiveSheet.Cells(multiple + 2, 1), ActiveSheet.Cells(multiple + 101, 2))
'Autofill the Region, Product and Product Type for each Cashflow
Next i
'Repeat for Years 1 to 100
Application.ScreenUpdating = False
'Do not update screen while executing code
ThisWorkbook.ActiveSheet.Cells.ClearFormats
'Clear formatting in Output Worksheet
Set ws = Nothing
End Sub
What you want to do is stay away from using Select/Selection etc and rather use indexed based direct references such as Ranges. I used Select/Selection in the begining as well. Here is some data on How to avoid using Select in Excel VBA macros
I am not exactly sure as to what your script is doing with the Multiple etc, but the script below will copy the Cells 10 to 100 from Sheet 7.1 and paste the in sheet Q_Sheet7.1 in Range A1:100 it will do this for Columns 1 to 10.
I am sure you can adapt it to your script.
Sub CopyPasteUsingRange()
Dim oRng As Range
Dim Sht71 As Worksheet
Dim ShtQ71 As Worksheet
Dim rawcolcount As Long
Set Sht71 = ActiveWorkbook.Worksheets("7.1")
Set ShtQ71 = ActiveWorkbook.Worksheets("Q_Sheet7.1")
'just for my example
rawcolcount = 10
For i = 1 To rawcolcount
Set oRng = Range(Sht71.Cells(10, i), Sht71.Cells(110, i))
oRng.Copy
ShtQ71.Range(Cells(1, i), Cells(110, i)).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
Next i
End Sub

VBA to copy and count words of a specific column and move them to another sheet

What I am trying to achieve is a VBA code to copy and count all words which are in a column and move it to another sheet sorted by hight frequency to lower. The number of rows can be different. See below:
Column1:
Finance
SAP
Finance
HR
Design
Design
HR
People
SAP
SAP
New sheet:
SAP 3
Finance 2
Design 2
SAP 2
HR 2
People 1
Any idea how to do this?
Many thanks.
I think the test approach will be to create pivot table and add row Lables and count of the column.
http://www.thespreadsheetguru.com/blog/2014/9/27/vba-guide-excel-pivot-tables
this will let you know how to create pivot and do the needful.
Thanks,
This will work, just need to sort the 'List' worksheet on Column B after running this:
Sub Count_Sort()
Dim lastRow As Integer
Dim ws As String
Dim c As Range
ws = ActiveSheet.Name
lastRow = LastUsedRow
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$A$" & lastRow).RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Name = "List"
Sheets(ws).Activate
Set c = Range("A1")
Set d = Sheets("List").Range("A1")
Do While Not IsEmpty(c)
Do While Not IsEmpty(d)
If c.Value = d.Value Then
d.Offset(0, 1).Value = d.Offset(0, 1).Value + 1
Set d = d.Offset(1, 0)
Exit Do
End If
Set d = d.Offset(1, 0)
Loop
Set c = c.Offset(1, 0)
Set d = Sheets("List").Range("A1")
Loop
End Sub
Public Function LastUsedRow()
LastUsedRow = [A65536].End(xlUp).Row
End Function

Excel, VBA: How can I copy paste data to new workbook when 1 conditional applying to multiple ranges?

I am a total n00b when it comes to excel and vba.
Any help would be much appreciated.
There is data from a to k in excel.
I am trying to:
Check whether E>2, to export G(x), E(x), and J(x) for all lines (columns) where this is the case.
I can't manage to select properly, and joins this with conditional successfully.
In addition, my pasting is super random.
I am trying to export it to a given filename # place, but haven't really gotten that far because cannot event export properly to different sheet in same workbook.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim Value As Range
Dim Copyarea1 As Range
Dim Copyarea2 As Range
Dim Copyarea3 As Range
Dim Copymaster As Range
Dim Pastesheet As Range
Sheet4.Activate
sheet1.Activate
Set Copyarea1 = sheet1.Range("F2")
Set Copyarea2 = sheet1.Range("H2")
Set Copyarea3 = sheet1.Range("I2")
Set Copymaster = Union(Copyarea1, Copyarea2, Copyarea3)
sheet1.Select
For Each Value In Range(["H2:H2539"])
If Value > 2 Then
Value.Select
Selection.Copy
Else: ActiveCell.Offset(1, 0).Activate
End If
If Value = "" Then Exit Sub
Sheet4.Select
Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(1, 0).Activate
sheet1.Activate
Next
Application.ScreenUpdating = True
End Sub
When I replace Value with copy master I get correct initial selection but fail at offsetting. and the export part is no good.
Only values to be copied, cells have formulas.
This code at first counts rows in workbook Book2.xlsm sheet1 and then go through all cells in original workbook range H2:H2539. If value is more then 2 then values from this row in columns F, H and I are pasted in A, B, C row in workbook Book2.xlsm sheet1 in first empty row.
Private Sub CommandButton1_Click()
Workbooks.Open Filename:="C:\Users\User\Desktop\Book2.xlsm" 'change path to your workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = ThisWorkbook.Sheets("sheet1")
Set sh2 = Workbooks("Book2.xlsm").Sheets("sheet1")
Application.ScreenUpdating = False
'counts rows in sheet2 column A (this is where values are going to be copied)
If IsEmpty(sh2.Range("A1").End(xlDown)) = True Then
y = 1
Else
y = sh2.Range("A1", sh2.Range("A1").End(xlDown)).Rows.Count + 1
End If
For i = 2 To 2539 'number of rows in your range (sheet1)
If sh1.Cells(i, 8) > 2 Then
sh2.Cells(y, 1) = sh1.Cells(i, 8).Offset(0, -2)
sh2.Cells(y, 1).Offset(0, 1) = sh1.Cells(i, 8)
sh2.Cells(y, 1).Offset(0, 2) = sh1.Cells(i, 8).Offset(0, 1)
y = y + 1
ElseIf sh1.Cells(i, 8) = "" Then: Exit Sub
End If
Next i
Application.ScreenUpdating = True
Workbooks("2.xlsm").Close savechanges:=True 'closes your second workbook and save changes
End Sub

Select multiple rows depending on value of A1

I have a spreadsheet with employees and data listed. The drop-down in A1 lets someone select the employee and then it hides the rows for all other employees. I want to add the names of supervisors in the drop-down of A1 and have it select only the employees under that supervisor and hide the rest. The number of employees under each supervisor ranges from 3 to 6.
This is what I have to hide the rows when selecting a single employee :
The data is on worksheet1 and the list of employees and supervisors is on sheet2
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v As Variant, i, j As Long
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveWindow.FreezePanes = False
UsedRange.Rows.Hidden = False
If IsEmpty(Cells(1, 1)) Then Exit Sub
v = Cells(1, 1).Value
For i = 2 To 40 ' Show/Hide the Analysts rows - Add/Substract to the second number when adding/removing analysts
If Not Cells(i, 1) = v Then Rows(i).Hidden = True
If v = "Select Analysts/Supervisors" Then Rows(i).Hidden = False
Next i
Cells(2, 1).Select
ActiveWindow.FreezePanes = True
Cells(2, 1).Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Anyone got any ideas on how to do this? I'm using Excel 2010
I hope i did right understand your question and excel workbook stucture.
You have to create range on the data sheet (in this example its named range: 'rngSupervisors')
In this range you put your supervisors names (column headers)
under each supervisor you write the employees. Each row, 1 employee.
The supervisors itself must be in your employee list to select it, for drop down.
so the data worksheet has for eaxample:
B1: supervisor1
C1: supervisor2
D1: supervisor3
than the employees
B2: emplyee1_UnderSupervisor1
B2: emplyee2_UnderSupervisor1
B2: emplyee3_UnderSupervisor1
C2: emplyee1_UnderSupervisor2
C2: emplyee2_UnderSupervisor2
.
.
then you have to name this range "B1:D1" as "rngSupervisors"
In this example the data worksheet is the second one. I would advise you to use the named worksheet, or better direct reference it (give name of worksheet in VBA editor, than you can reference it directly).
Here i created the a function that tests if Argument1-string is the advisor of Argument2-string. Than you can use this function to test it, if it is false, and the name dont match, than you can hide the row.
I tried to make minimal modifications on your code (but it could be good improved.. or the method you make it all, could be probably realised with excel filters)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v As Variant, i, j As Long
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveWindow.FreezePanes = False
UsedRange.Rows.Hidden = False
If IsEmpty(Cells(1, 1)) Then Exit Sub
v = Cells(1, 1).Value
For i = 2 To 40 ' Show/Hide the Analysts rows - Add/Substract to the second number when adding/removing analysts
'if the name is not under selected supervisor, and its not selected name, hide the row
If Not isSupervisor(CStr(v), CStr(Cells(i, 1).Value)) And Not Cells(i, 1) = v Then
Rows(i).Hidden = True
End If
Next i
Cells(2, 1).Select
ActiveWindow.FreezePanes = True
Cells(2, 1).Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'returns true if sEmplName is under sSupName supervisor
Private Function isSupervisor(sSupName As String, sEmplName As String) As Boolean
Dim wksDataSheet As Worksheet 'worksheet where supervisor and employes data saved
Dim rngSupCell As Range 'range with supervisor names/headers
Dim lSupColumn As Long 'column of selected supervisor
Dim lSupLastRow As Long 'last row with employes names of column of supervisor
Dim lCurrentRow As Long 'counter for current row by iteration
Set wksDataSheet = ThisWorkbook.Sheets(2) 'or some named sheet for example ThisWorkbook.Sheets("DataSheet")
With wksDataSheet
'for each cell in supervisor names range
For Each rngSupCell In .Range("rngSupervisors") 'could be .Range("A3:A6") for example
'if supervisor name found in the range
If StrComp(rngSupCell.Value, sSupName, vbTextCompare) = 0 Then
'get column
lSupColumn = rngSupCell.Column
'get last row
lSupLastRow = .Cells(.Rows.Count, "A").End(xlUp).row
'for each employee name, starts from next row
For lCurrentRow = rngSupCell.row + 1 To lSupLastRow
'if equals, return true, exit.
If StrComp(.Cells(lCurrentRow, lSupColumn).Value, sEmplName, vbTextCompare) = 0 Then
isSupervisor = True
Exit Function
End If
Next lCurrentRow
End If
Next rngSupCell
End With
'nothing found, return false
isSupervisor = False
End Function