VBA代码过滤数据并创建新的工作表并将数据传输给它 [英] VBA code to Filter data and create a new sheet and transfer data to it

问题描述

我很喜欢VBA for excel，我试图在一个包含以下四个条件的字符串（trsf，trf，transfer，trnsf）的列中使用四个标准的多重过滤器，但是我是只能做到这两个，我似乎不能做4，
我手动创建了一个名为转移的新工作表，但我希望代码自动创建新的工作表，并将其命名为转让。请帮助修改：允许四个条件并创建一个新的工作表并重新命名，并将过滤后的数据传输到新工作表，并将DataSheet还原到过滤器之前的默认状态。

  Sub ActivateJournalsSheet（）
 Dim wsj As Worksheet 
对于每个wsj在Worksheets 
如果wsj.Name& DataSheet然后
 wsj.Select 
 wsj.Application.Run传输
结束如果
下一个
 End Sub 
 Sub Transfers（）
 ActiveSheet.Range（$ A $ 1：$ H $ 4630）。AutoFilter字段：= 2，Criteria1：== * trsf *，运算符：= xlOr，_ 
 Criteria2：= Array b $ b trsfs，_ 
 trnsf，_ 
 transfer），_ 
运算符：= xlFilterValues 
 Worksheets.Add.Name =传输
 End Sub 
 
 Sub CopyPaste（）
 Dim ws As Worksheet 
对于每个ws在Worksheets 
如果ws.Name<> DataSheet然后
 ws.Select 
 ws.Application.RunMacroCopy
 End If 
 Next 
 End Sub 
 
 Sub MacroCopy （）
范围（A1：H4630）。选择
 Selection.Copy 
表格（传输）。粘贴
 End Sub 
  

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

 '确保在检查范围内存在trans或trsf Set TestTRANS =`CheckRng.Find（What：= trans，LookIn：= xlValues，LookAt：= xlWhole）设置TestTRSF = CheckRng.Find（什么：=trsf，LookIn：= xlValues，LookAt：= xlWhole）如果TestTRANS不是，TestTRSF不是，那么MsgBox（在列B中找不到trans或trsf，退出！）退出子结束如果
  

我还添加了第二个条件作为数组，但会给出语法错误。 ..代码运行正常与两个最初的两个标准，但我想添加trfs和trnsf

 与DataRng 
 .AutoFilter字段：= 2，Criteria1：== * trsf *，运算符：= xlOr，Criteria2：= Array（_trfs，_trnsf），_Operator：= xlFilterValues 
 End with 
  

解决方案

我认为下面的代码会执行您要查找的所有内容：

  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 
 
'确保数据表存在
如果不是这样的话（DataSheet，ThisWorkbook）然后
 MsgBox（No sheet namedDataSheetfound，exiting！）
 Exit Sub 
 End If 
 
'分配数据表，数据范围和检查范围
设置DataSheet = ThisWorkbook.Worksheets（数据
设置DataRng = DataSheet.Range（$ A $ 1：$ H $ 4630）
设置CheckRng = DataSheet.Range（$ B $ 1：$ B $ 4630）
 
'确保在检查范围内存在trans或trsf 
 Set TestTRANS = CheckRng.Find（What：=trans，LookIn：= xlValues，LookAt：= xlWhole）
 Set TestTRSF = CheckRng.Find（什么：=trsf，LookIn：= xlValues，LookAt：= xlWhole）
如果TestTRANS不是，TestTRSF不是然后
 MsgBox（找不到trans或B中的trsf退出！）
退出子
结束如果
 
'应用自动过滤器并创建复制范围
使用DataRng 
 .AutoFilter字段：= 2，Criteria1：== * trsf *，运算符：= xlOr，Criteria2：== * trans *
结束
设置CopyRng = DataRng.SpecialCells（xlCellTypeVisible） 
 DataSheet.AutoFilterMode = False 
 
'确保名为transfer的工作表不存在，如果它然后删除它
如果DoesSheetExist（传输，ThisWorkbook）然后
 MsgBox（糟糕，转移表已经exis TS。 
设置TransfersSheet =工作表（传输）
 TransfersSheet.Delete 
 End If 
 
'创建传输表
设置TransfersSheet = Worksheets.Add 
 TransfersSheet.Name =传输
 
'将复制的范围粘贴到传输表
 CopyRng.Copy 
 TransfersSheet.Range（A1） .PasteSpecial Paste：= xlPasteAll 
 
 End Sub 
 
公共函数DoesSheetExist（SheetName As String，BookName As Workbook）As Boolean 
 Dim obj As Object 
 On Error Resume Next 
'如果有错误，工作表不存在
设置obj = BookName.Worksheets（SheetName）
如果Err = 0然后
 DoesSheetExist = True 
 Else 
 DoesSheetExist = False 
结束如果
出现错误GoTo 0 
结束函数
  

I'm new to VBA for excel, I'm trying to do a multiple filter with four criteria on a column containing either of the following strings (trsf ,trf, transfer, trnsf) that is 4 criteria, but I was only able to do it for two, I can't seem to do it for 4, I manually created a new sheet called Transfers but I want the code to automatically create the new sheet and name it Transfers. Please help modify: to allow four criteria and create a new sheet and rename it and transfer the filtered data to the new sheet ,and restore the DataSheet Back to its default state before the 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

Thanks Dan, i had to delete this because the strings 'trans' and 'trsf' appear as part of other strings not just as the only content of cells.

'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`

I also added the second criteria as an array but it'd giving a syntax error . .. the code runs fine with the two initial two criteria , but I want to add trfs and trnsf

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

解决方案

I think the code below does everything you're looking for:

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代码过滤数据并创建新的工作表并将数据传输给它的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！