VBA для выбора строки на основе двух критериев;Одно точное значение, а другое значение - одно из нескольких в списке на другом листе

Question

Предоставленный код в настоящее время скопирует строку и поместит ее на другой лист, если код найдет строку, содержащую как «OlsonJo» (Value =) в одной ячейке, так и другую ячейку, содержащую «UT- *» (Value Like (thx, S. Craner)).

Я хотел бы изменить этот код, чтобы он по-прежнему включал Value = "OlsonJo", однако второй критерий был бы из списка.Например, если строка содержит «OlsonJo», а второй критерий равен одному из них в приведенном ниже списке (который находится на другом листе в рабочей книге).

UHS-Committee
UHS-Admin-Managing UHS Services
UHS-Admin-Meetings with staff
UHS-Admin-Communicating w/staff
UHS-Admin-Update Lab Test Formul
UHS-Admin-Write Procedure Manual
UHS-Admin-Candidate Interview
UHS-Admin-Consult Emp & Rev Qual
UHS-Admin-Scheduling functions
UHS-Admin-Strategic Lab Plan
UHS-Admin-Budget Planning
UHS-Admin-Equip Select & Acquis.
UHS-Admin-Test Select & Valid.
UHS-Sup/Ment Res/Fell-Sup Pa&Oth
UHS-Sup/Ment Res/Fell-1-1, Did
UHS-Sup/Ment Res/Fell-Sign O Case
UHS-Res/Fell-Interv ACGME pos
UHS-Res/Fell-Oth Act;Ad Res Prog
UHS-QA-Design/Analyze Lab QA Act
UHS-QA-Interpret Qual. Data/Rep
UHS-QA-Rev. Ext PT,QC,QM,& QAP
UHS-QA- Rev Investing Record lab events deviations
UHS-QA-Lab/Hospital Accred Act.
UHS-Autopsy-UHS Patient Autopsy
UHS-Analy-Clin Inform/Analy
UHS-Analy-Clin Inform EPIC Build
UHS-Analy-Proc.Improvem Act
UHS-Analy-Pop Hlth/Interd Coll
UHS-Analy-Clin Lab Util Mngt

, скопируйте эту строку и поместите ее вназначенный лист!

Мне не удалось найти учебник, включающий извлечение из списка опций.Опять же, заранее спасибо за ваше время!

Sub FindOlsonUT()   
    Dim i, LastRow
    LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row 'this line finds the last row used in a sheet.

    Sheets("Sheet2").Range("A2:M1000").ClearContents 'this line clears the contents of Sheet2 from A2 to M1000.

    For i = 2 To LastRow
        If Sheets("Sheet1").Cells(i, "D").Value = "OlsonJo" And Sheets("Sheet1").Cells(i, "H").Value Like "UT-*" Then 'the two criteria are in this line; exactly "OlsonJo" and contains "UT-"
            Sheets("Sheet1").Cells(i, "D").EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1) 'destination is Sheet 2
        End If
    Next i
End Sub

Answer 1

Проходя длинный путь вокруг сарая, но это работает. Разделены на сабы. Одна подпрограмма ищет все строки с одним из 8 или 9 различных значений, таких как "UHS-

If Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Admin*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Sup/Ment Res/Fell-*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Res/Fell-*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-QA-*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Sup*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Autopsy-UHS Patient Autopsy" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Analy-*" Then

и копирует эти строки в Лист 2.

Вторая подпрограмма разделяет эти задачи на разные листы по пользователю.

Sub FindFiebelkornUHSAOA()
Dim i, LastRow
LastRow = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row 'this line finds the last row used in a sheet.
Sheets("Sheet3").Range("A2:M1000").ClearContents 'this line clears the contents of Sheet3 from A11 to M1000. 
For i = 11 To LastRow
If Sheets("Sheet2").Cells(i, "D").Value = "FiebelkornKr" Then 
Sheets("Sheet2").Cells(i, "D").EntireRow.Copy Destination:=Sheets("Sheet3").Range("A" 
& Rows.Count).End(xlUp).Offset(1) '
End If
Next i
End Sub

Пункт назначения - лист 3 для строк, содержащих FiebelkornKr.

Вот код, который достигает результата, который я ищу. К сожалению, я должен применить это к 40-50 пользователям.

Option Explicit
Sub PathDocsTimeSheets()
Call ExtractUHSAOA
Call FindFiebelkornUHSAOA
Call FindFiebelkornUHSClinCare
Call FindGreebonUHSAOA
Call FindGreebonUHSClinCare
End Sub

Sub ExtractUHSAOA()
Dim i, LastRow
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row 'this line finds the last row used in a sheet.
Sheets("Sheet2").Range("A11:M1000").ClearContents f 
Sheet2 from A11to M1000.
For i = 11 To LastRow
If Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Admin*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Sup/Ment Res/Fell-*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Res/Fell-*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-QA-*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Sup*" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Autopsy-UHS Patient Autopsy" Or 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Analy-*" Then
Sheets("Sheet1").Cells(i, "D").EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1) 'destination is Sheet2
End If
Next i
End Sub


Sub FindFiebelkornUHSAOA()
Dim i, LastRow
LastRow = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row 'this line finds the last row used in a sheet.
Sheets("Sheet3").Range("A2:M1000").ClearContents 'this line clears the contents of Sheet3 from A11 to M1000.
For i = 11 To LastRow
If Sheets("Sheet2").Cells(i, "D").Value = "FiebelkornKr" Then 
Sheets("Sheet2").Cells(i, "D").EntireRow.Copy Destination:=Sheets("Sheet3").Range("A" 
& Rows.Count).End(xlUp).Offset(1) 'destination is Sheet 3
End If
Next i
End Sub

Sub FindFiebelkornUHSClinCare()
Dim i, LastRow
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row 'this line finds the last row used in a sheet.
Sheets("Sheet4").Range("A11:M1000").ClearContents
For i = 11 To LastRow
If Sheets("Sheet1").Cells(i, "D").Value = "FiebelkornKr" And 
Sheets("Sheet1").Cells(i, "H").Value Like "UHS-Clin*" Then 'finds rows that have both "FiebelkornKr" exactly in column D and another cell that contains "UHS-Clin" in column H.
Sheets("Sheet1").Cells(i, "D").EntireRow.Copy Destination:=Sheets("Sheet4").Range("A" 
& Rows.Count).End(xlUp).Offset(1) 'destination is Sheet4
End If
Next i
End Sub

Спасибо за предложения и комментарии.