Question

我是VBA for excel的新手，我正在尝试对包含以下字符串（trsf，trf，transfer，trnsf）的列的四个标准进行多重过滤，这是4个标准，但我是只能做到两个，我似乎无法做到4，我手动创建了一个名为Transfers的新工作表，但我想让代码自动创建新工作表并将其命名为Transfers。请帮助修改：允许四个条件并创建一个新工作表并重命名并将过滤后的数据传输到新工作表，并将数据表恢复到过滤器之前的默认状态。

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

谢谢Dan，我不得不删除它，因为字符串'trans'和'trsf'显示为其他字符串的一部分，而不仅仅是单元格的唯一内容。

'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

VBA代码用于过滤数据并创建新工作表并将数据传输到该工作表

1 个答案: