VBA Alternative for Vlookup - Check Peoples names

Trevor G

Well-known Member
Joined
Jul 17, 2008
Messages
6,717
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
Platform
  1. Windows
Hi folks,

I have recently taken on some voluntary work for a number of pastoral care teams. I am looking to use VBA to identify if someone hasn't been assigned a care manager.

I have 10 sheets showing Care Teams (1 to 10) - Who the manager is in Cell A1 and the Sheet name is the same, and who is being looked after by that care manager, and 1 sheet which is a download of every person under the voluntary organisation who should be looked after. I am trying to identify who has yet to be assigned a care manager.

I currently do this through inserting columns and then adding the care manager in column B to identify the Team and then create IFERROR and VLOOKUP (10 variables) formula on the download sheet for everyone listed, which is time consuming, as I know I will have to do this for multiple locations I would like VBA to do this.

Column A starting in Cell A3 downwards in each Care Team sheet shows the names of those who have been assigned a care manager . On the download sheet (or create a new sheet) I am looking to identify who hasn't been assigned yet. Column A on the download sheet lists the everyone's names and Column E is where I am identifying who the care manager is or indicating who hasn't been assigned.

Any help is much appreciated.
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
To test this insert a new sheet and rename it "Unallocated"
The code lists unallocated names from the 2nd sheet to the 11th - so you may need to amend those numbers

VBA Code:
Sub UnallocatedNames()
    Dim last As Range, cel As Range, x As Long, aName As String, aSheet As String
    Set last = Sheets("Unallocated").Cells(Rows.Count, 1)
    For x = 2 To 11
        With Sheets(x)
            aSheet = .Name
            For Each cel In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
                aName = cel.Text
                If cel.Offset(, 1) = "" Then
                    If aName <> "" Then last.End(xlUp).Offset(1).Resize(, 2) = Array(aSheet, aName)
                End If
        Next cel
        End With
    Next x
End Sub
 
Upvote 0
Looks like @Yongle has beaten me to it?

However, having just tested Yongle's code, it would appear that we have different interpretations of the required result? ?
Please find my effort below....

VBA Code:
Sub Check_Care()

'**** Assumes that the Download sheet is the LEFTMOST tab
' and that the x Care Team sheets are the x rightmost tabs

Dim NRange As Range, CTRange As Range
Dim s As Integer, r As Integer, i As Integer
Dim DLR As Integer, LR As Integer
'Edit Download Sheet Name to suit

Application.ScreenUpdating = False
With Sheets("Download")
    DLR = .Range("A" & Rows.Count).End(xlUp).Row
    Set NRange = .Range("A1:A" & DLR)
    Set CTRange = .Range("B1")
End With

'Check Care Team Sheets vs Download
For s = 2 To Sheets.Count
    Set WS = Sheets(s)
    LR = WS.Range("A" & Rows.Count).End(xlUp).Row
   
    For r = 3 To LR
    On Error Resume Next
        i = Application.WorksheetFunction.Match(WS.Range("A" & r).Value, NRange, 0)
       
        If Err.Number = 0 Then
            CTRange.Offset(i - 1, 0) = WS.Range("A1").Value
        Else
      
            WS.Range("B" & r) = "< Cannot Find In Download"
        End If
       
    Next r
   
Next s

Application.ScreenUpdating = True
On Error GoTo 0

End Sub

Hope that helps.
 
Upvote 0
Sheet snippets...

Book1
ABC
1Name Care Team 
2Person 1
3Person 2
4Person 3
5Person 4
6Person 5Care Team 1
7Person 6Care Team 2
8Person 7Care Team 1
9Person 8Care Team 1
10Person 9Care Team 1
11Person 10Care Team 1
12Person 11Care Team 1
13Person 12Care Team 1
14Person 13Care Team 1
15Person 14Care Team 1
16Person 15Care Team 2
17Person 16Care Team 2
18Person 17Care Team 2
19Person 18Care Team 2
20Person 19Care Team 2
21Person 20
Download


Book1
ABCD
1Care Team 1 
2Name
3Person 5
4Person 14
5Person 7
6Person 8
7Person 9
8Person 10
9Person 11
10Person 12
11Person 13
12Person 99< Cannot Find In Download
13Person 100< Cannot Find In Download
14
Care Team 1


Book1
ABC
1Care Team 2 
2Name
3Person 6
4Person 15
5Person 16
6Person 17
7Person 18
8Person 19
Care Team 2
 
Upvote 0
To test this insert a new sheet and rename it "Unallocated"
The code lists unallocated names from the 2nd sheet to the 11th - so you may need to amend those numbers

VBA Code:
Sub UnallocatedNames()
    Dim last As Range, cel As Range, x As Long, aName As String, aSheet As String
    Set last = Sheets("Unallocated").Cells(Rows.Count, 1)
    For x = 2 To 11
        With Sheets(x)
            aSheet = .Name
            For Each cel In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
                aName = cel.Text
                If cel.Offset(, 1) = "" Then
                    If aName <> "" Then last.End(xlUp).Offset(1).Resize(, 2) = Array(aSheet, aName)
                End If
        Next cel
        End With
    Next x
End Sub

Hi Yongle thank you for replying. Your code provides me with a list of who has been allocated a care manager, which is great thank you. But I am looking for those who haven't been provided a care manager.
 
Upvote 0
Looks like @Yongle has beaten me to it?

However, having just tested Yongle's code, it would appear that we have different interpretations of the required result? ?
Please find my effort below....

VBA Code:
Sub Check_Care()

'**** Assumes that the Download sheet is the LEFTMOST tab
' and that the x Care Team sheets are the x rightmost tabs

Dim NRange As Range, CTRange As Range
Dim s As Integer, r As Integer, i As Integer
Dim DLR As Integer, LR As Integer
'Edit Download Sheet Name to suit

Application.ScreenUpdating = False
With Sheets("Download")
    DLR = .Range("A" & Rows.Count).End(xlUp).Row
    Set NRange = .Range("A1:A" & DLR)
    Set CTRange = .Range("B1")
End With

'Check Care Team Sheets vs Download
For s = 2 To Sheets.Count
    Set WS = Sheets(s)
    LR = WS.Range("A" & Rows.Count).End(xlUp).Row
  
    For r = 3 To LR
    On Error Resume Next
        i = Application.WorksheetFunction.Match(WS.Range("A" & r).Value, NRange, 0)
      
        If Err.Number = 0 Then
            CTRange.Offset(i - 1, 0) = WS.Range("A1").Value
        Else
     
            WS.Range("B" & r) = "< Cannot Find In Download"
        End If
      
    Next r
  
Next s

Application.ScreenUpdating = True
On Error GoTo 0

End Sub

Hope that helps.
Tony thank you for replying, the code has provided me with knowing who has not yet been allocated a care manager. This will save a lot of time and will ensure that people aren't missed out. Thank you Tony.
 
Upvote 0
Trevor, you are most welcome and, thanks go to you for the volunteer work that you do!!!
 
Upvote 0

Forum statistics

Threads
1,213,528
Messages
6,114,154
Members
448,553
Latest member
slaytonpa

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top