循环到AutoFilter并评估特定条件

我正在做一个项目：

1. 根据员工姓名从一个工作簿中自动筛选数据（原始数据报告）
2. 将该AutoFilter的结果粘贴到共享该员工姓名的工作表中的另一个WB中，以便可以针对该个人进行进一步的分析

我不确定原始数据报告的格式是否一致，所以我将来可能需要对我的代码进行调整。 我需要一些循环，这将使这个过程更有效地运行。

注意：这个过程将不得不重复最多200次，以考虑每个员工，见下面的代码..

Dim sourceWB As Workbook Dim destWB As Workbook Set sourceWB = ThisWorkbook Workbooks.Open Filename:="C:\users\andrew.godish\Desktop\ChadAT&T\CSCO Separated Data.xlsm" Set destWB = ActiveWorkbook 'Code that needs to be Repeated sourceWB.Sheets("Sheet1").Range("A1:K1").AutoFilter Field:=2, Criteria1:="Employee 1" sourceWB.Sheets("Sheet1").AutoFilter.Range.Copy Destination:=destWB.Sheets("Employee 1").Range("A" & Rows.Count).End(xlUp) ActiveCell.Columns("A:P").EntireColumn.Select ActiveCell.Columns("A:P").EntireColumn.EntireColumn.AutoFit If sourceWB.Sheets("Sheet1").AutoFilterMode Then sourceWB.Sheets("Sheet1").ShowAllData 'Code that needs to be Repeated sourceWB.Sheets("Sheet1").Range("A1:K1").AutoFilter Field:=2, Criteria1:="Employee 2" sourceWB.Sheets("Sheet1").AutoFilter.Range.Copy Destination:=destWB.Sheets("Employee 2").Range("A" & Rows.Count).End(xlUp) ActiveCell.Columns("A:P").EntireColumn.Select ActiveCell.Columns("A:P").EntireColumn.EntireColumn.AutoFit If sourceWB.Sheets("Sheet1").AutoFilterMode Then sourceWB.Sheets("Sheet1").ShowAllData 'Code that needs to be Repeated sourceWB.Sheets("Sheet1").Range("A1:K1").AutoFilter Field:=2, Criteria1:="Employee 3" sourceWB.Sheets("Sheet1").AutoFilter.Range.Copy Destination:=destWB.Sheets("Employee 3").Range("A" & Rows.Count).End(xlUp) ActiveCell.Columns("A:P").EntireColumn.Select ActiveCell.Columns("A:P").EntireColumn.EntireColumn.AutoFit If sourceWB.Sheets("Sheet1").AutoFilterMode Then sourceWB.Sheets("Sheet1").ShowAllData 

所以，正如你所看到的，通过编辑这些重复的代码段中的200个并不是一个真正的select。 我知道我需要某种循环，我正在考虑一个For-Next循环，但是我对VBA相对来说还是比较新的，我不能把我的脑袋想象成是我需要成为循环variables的工具。 谢谢大家！

Answer 1

尝试这个

 Option Explicit Sub main() Dim sourceWB As Workbook Dim destWB As Workbook Dim dataRng As Range, employeesRng As Range, cell As Range Set sourceWB = ThisWorkbook Workbooks.Open Filename:="C:\users\andrew.godish\Desktop\ChadAT&T\CSCO Separated Data.xlsm" Set destWB = ActiveWorkbook Set dataRng = sourceWB.Sheets("Sheet1").Range("A1:K1") '<~~ set your range with data, headers included Set employeesRng = sourceWB.Sheets("Employees").Range("A:A") '<~~ set your range with employees to process. I thought of names in column A of an "Empolyees" sheet of ThisWorkbook employeesRng.RemoveDuplicates Columns:=Array(1), Header:=xlYes '<~~ get rid of employeess name duplicates With dataRng For Each cell In employeesRng.SpecialCells(xlCellTypeConstants, xlTextValues) '<~~ loop through actual valid employees names in the empolyees range (no dupes and no blanks) .AutoFilter Field:=2, Criteria1:=cell.Value If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<~~ check if there are any filtered values (headers are always there, so look for at least 2 values) .Parent.AutoFilter.Range.Copy Destination:=destWB.Sheets(cell.Value).Range("A" & Rows.Count).End(xlUp) destWB.Sheets(cell.Value).Columns("A:P").EntireColumn.AutoFit End If .AutoFilter Next cell End With End Sub 

当然你必须确定destWB每个员工名字已经有一张

否则你必须实现一个表单存在处理技术，如你可能会在这里