VBA代码来过滤数据，并创build一个新的工作表和传输数据

我是新来的VBA为Excel，我试图做一个包含以下任何一个string（trsf，trf，转让，trnsf）四个标准，但我只能够做两个，我似乎无法做到4，我手动创build了一个新的工作表，称为转移，但我希望代码自动创build新工作表，并将其命名为转移。 请帮助修改：允许四个条件并创build一个新工作表并重新命名，并将过滤的数据传输到新工作表，并将DataSheet恢复到filter之前的默认状态。

Sub ActivateJournalsSheet() Dim wsj As Worksheet For Each wsj In Worksheets If wsj.Name <> "DataSheet" Then wsj.Select wsj.Application.Run "Transfers" End If Next End Sub Sub Transfers() ActiveSheet.Range("$A$1:$H$4630").AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, _ Criteria2:=Array( _ trsfs, _ trnsf, _ transfer), _ Operator:=xlFilterValues Worksheets.Add.Name = "Transfers" End Sub Sub CopyPaste() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "DataSheet" Then ws.Select ws.Application.Run "MacroCopy" End If Next End Sub Sub MacroCopy() Range("A1:H4630").Select Selection.Copy Sheets("Transfers").Paste End Sub 

感谢丹，我不得不删除这个，因为string“trans”和“trsf”作为其他string的一部分而不仅仅是单元格的内容。

 'make sure that trans or trsf exists in the check range Set TestTRANS = `CheckRng.Find(What:="trans", LookIn:=xlValues, LookAt:=xlWhole) Set TestTRSF = CheckRng.Find(What:="trsf", LookIn:=xlValues, LookAt:=xlWhole) If TestTRANS Is Nothing And TestTRSF Is Nothing Then MsgBox ("Could not find ""trans"" or ""trsf"" in column B, exiting!") Exit Sub End If` 

我也添加了第二个标准作为一个数组，但它会给一个语法错误。 ..代码运行良好的两个最初的两个标准，但我想添加trfs和trnsf

 With DataRng .AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, Criteria2:=Array( _trfs, _trnsf), _Operator:=xlFilterValues End With 

Answer 1

我认为下面的代码会做你想要的一切：

 Option Explicit Sub BringItAllTogether() Dim DataSheet As Worksheet, TransfersSheet As Worksheet Dim DataRng As Range, CheckRng As Range, _ TestTRANS As Range, TestTRSF As Range, _ CopyRng As Range, PasteRng As Range 'make sure the data sheet exists If Not DoesSheetExist("DataSheet", ThisWorkbook) Then MsgBox ("No sheet named ""DataSheet"" found, exiting!") Exit Sub End If 'assign the data sheet, data range and check range Set DataSheet = ThisWorkbook.Worksheets("DataSheet") Set DataRng = DataSheet.Range("$A$1:$H$4630") Set CheckRng = DataSheet.Range("$B$1:$B$4630") 'make sure that trans or trsf exists in the check range Set TestTRANS = CheckRng.Find(What:="trans", LookIn:=xlValues, LookAt:=xlWhole) Set TestTRSF = CheckRng.Find(What:="trsf", LookIn:=xlValues, LookAt:=xlWhole) If TestTRANS Is Nothing And TestTRSF Is Nothing Then MsgBox ("Could not find ""trans"" or ""trsf"" in column B, exiting!") Exit Sub End If 'apply autofilter and create copy range With DataRng .AutoFilter Field:=2, Criteria1:="=*trsf*", Operator:=xlOr, Criteria2:="=*trans*" End With Set CopyRng = DataRng.SpecialCells(xlCellTypeVisible) DataSheet.AutoFilterMode = False 'make sure a sheet named transfers doesn't already exist, if it does then delete it If DoesSheetExist("Transfers", ThisWorkbook) Then MsgBox ("Whoops, ""Transfers"" sheet already exists. Deleting it!") Set TransfersSheet = Worksheets("Transfers") TransfersSheet.Delete End If 'create transfers sheet Set TransfersSheet = Worksheets.Add TransfersSheet.Name = "Transfers" 'paste the copied range to the transfers sheet CopyRng.Copy TransfersSheet.Range("A1").PasteSpecial Paste:=xlPasteAll End Sub Public Function DoesSheetExist(SheetName As String, BookName As Workbook) As Boolean Dim obj As Object On Error Resume Next 'if there is an error, sheet doesn't exist Set obj = BookName.Worksheets(SheetName) If Err = 0 Then DoesSheetExist = True Else DoesSheetExist = False End If On Error GoTo 0 End Function