Блог

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

Я хотел бы изменить этот код, чтобы он по-прежнему включал значение =»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 amp; Rev Qual
UHS-Admin-Scheduling functions
UHS-Admin-Strategic Lab Plan
UHS-Admin-Budget Planning
UHS-Admin-Equip Select amp; Acquis.
UHS-Admin-Test Select amp; Valid.
UHS-Sup/Ment Res/Fell-Sup Paamp;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,amp; 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" amp; 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" amp; Rows.Count).End(xlUp).Offset(1) 'destination is Sheet 2
        End If
    Next i
End Sub
  

Это долгий путь вокруг сарая, но это работает. Разделено на подразделы. Один подраздел ищет все строки с одним из 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" amp; 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" 
amp; 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" amp; 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" amp; 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" amp; 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" 
amp; 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" amp; 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" 
amp; Rows.Count).End(xlUp).Offset(1) 'destination is Sheet4
End If
Next i
End Sub
  

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