Excel VBA宏要进行筛选，请从列中复制指定值，然后创建并粘贴到具有该列名的新工作表中_Excel_Vba

Excel VBA宏要进行筛选，请从列中复制指定值，然后创建并粘贴到具有该列名的新工作表中

excel vba

Excel VBA宏要进行筛选，请从列中复制指定值，然后创建并粘贴到具有该列名的新工作表中,excel,vba,Excel,Vba,我对VBA宏非常陌生。我对下面的宏进行了编码，该宏在包含“Ocean”的列“N”上进行过滤，并复制相应的数据。然后，它创建一个名为“Ocean”的新工作表，并将数据粘贴到其中或者是否可以对包含“Ocean”的N列进行筛选并删除不匹配的数据？请帮忙。下面是我的代码和excel截图，供参考 Dim Wf As Workbook Dim Tsht As Worksheet, FSht As Worksheet Dim lRow As Long, lRw As Long Set Wf = Activ

我对VBA宏非常陌生。我对下面的宏进行了编码，该宏在包含“Ocean”的列“N”上进行过滤，并复制相应的数据。然后，它创建一个名为“Ocean”的新工作表，并将数据粘贴到其中

或者是否可以对包含“Ocean”的N列进行筛选并删除不匹配的数据？请帮忙。下面是我的代码和excel截图，供参考

Dim Wf As Workbook
Dim Tsht As Worksheet, FSht As Worksheet
Dim lRow As Long, lRw As Long

Set Wf = ActiveWorkbook
Set Tsht = Wf.Sheets("Main")

With Tsht
        lRow = .Cells(.Rows.Count, "N").End(xlUp).Row
    End With
    
Application.AskToUpdateLinks = False


Set FSht = Wf.Sheets("Ocean")

    With FSht
        .AutoFilterMode = False
        lRw = .Cells(.Rows.Count, "C").End(xlUp).Row
        .Range("A" & lRw).AutoFilter Field:=2, Criteria1:="Ocean"
        .AutoFilter.Range.Copy

      End With

我希望宏仅拆分新工作表中包含Ocean的行，工作表名称为“Ocean”。或者宏应该只保留与海洋对应的数据，并删除其余的。。。请帮助……….

自动筛选副本这将删除工作表

Ocean

（如果存在）。然后，它将添加一个新的工作表，将其命名为

Ocean

，并将工作表

Main

中的过滤数据复制到其中

代码

Option Explicit

Sub AutoFilterCopy()

    Application.AskToUpdateLinks = False
    
    Dim wb As Workbook
    ' If the code is in the ActiveWorkbook you should use ThisWorkbook instead.
    Set wb = ActiveWorkbook
        
    ' Delete Target Worksheet.
    Dim FSht As Worksheet
    On Error Resume Next
    Set FSht = wb.Worksheets("Ocean")
    If Err.Number = 0 Then
        Application.DisplayAlerts = False
        FSht.Delete
        Application.DisplayAlerts = True
    End If
    On Error GoTo 0
    
    ' Define Target Worksheet.
    Set FSht = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    FSht.Name = "Ocean"
    
    ' Define Source Worksheet.
    Dim Tsht As Worksheet
    Set Tsht = wb.Worksheets("Main")
    With Tsht
        If .AutoFilterMode Then
            .AutoFilterMode = False
        End If
        ' 14 is column N
        .Range("A1").AutoFilter Field:=14, Criteria1:="Ocean"
        .AutoFilter.Range.Copy FSht.Range("A1")
    End With
    
    MsgBox "Worksheet created, data copied.", vbInformation, "Success"
    
End Sub

Option Explicit

Sub AutoFilterCopy()

    Application.AskToUpdateLinks = False
    
    Dim wb As Workbook
    ' If the code is in the ActiveWorkbook you should use ThisWorkbook instead.
    Set wb = ActiveWorkbook
        
    ' Delete Target Worksheet.
    Dim FSht As Worksheet
    On Error Resume Next
    Set FSht = wb.Worksheets("Ocean")
    If Err.Number = 0 Then
        Application.DisplayAlerts = False
        FSht.Delete
        Application.DisplayAlerts = True
    End If
    On Error GoTo 0
    
    ' Define Target Worksheet.
    Set FSht = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    FSht.Name = "Ocean"
    
    ' Define Source Worksheet.
    Dim Tsht As Worksheet
    Set Tsht = wb.Worksheets("Main")
    With Tsht
        If .AutoFilterMode Then
            .AutoFilterMode = False
        End If
        Const FieldName As String = "Mode"
        Dim FieldNumber As Long
        ' Note that there will be an error if "Mode" cannot be found.
        FieldNumber = Application.Match(FieldName, .Rows(1), 0)
        .Range("A1").AutoFilter Field:=FieldNumber, Criteria1:="Ocean"
        .AutoFilter.Range.Copy FSht.Range("A1")
    End With
    
    MsgBox "Worksheet created, data copied.", vbInformation, "Success"
    
End Sub

编辑：

OP不是列
```
N
```
（14），而是希望用标题“Mode”标识criteria列

编辑的代码

Option Explicit

Sub AutoFilterCopy()

    Application.AskToUpdateLinks = False
    
    Dim wb As Workbook
    ' If the code is in the ActiveWorkbook you should use ThisWorkbook instead.
    Set wb = ActiveWorkbook
        
    ' Delete Target Worksheet.
    Dim FSht As Worksheet
    On Error Resume Next
    Set FSht = wb.Worksheets("Ocean")
    If Err.Number = 0 Then
        Application.DisplayAlerts = False
        FSht.Delete
        Application.DisplayAlerts = True
    End If
    On Error GoTo 0
    
    ' Define Target Worksheet.
    Set FSht = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    FSht.Name = "Ocean"
    
    ' Define Source Worksheet.
    Dim Tsht As Worksheet
    Set Tsht = wb.Worksheets("Main")
    With Tsht
        If .AutoFilterMode Then
            .AutoFilterMode = False
        End If
        ' 14 is column N
        .Range("A1").AutoFilter Field:=14, Criteria1:="Ocean"
        .AutoFilter.Range.Copy FSht.Range("A1")
    End With
    
    MsgBox "Worksheet created, data copied.", vbInformation, "Success"
    
End Sub

Option Explicit

Sub AutoFilterCopy()

    Application.AskToUpdateLinks = False
    
    Dim wb As Workbook
    ' If the code is in the ActiveWorkbook you should use ThisWorkbook instead.
    Set wb = ActiveWorkbook
        
    ' Delete Target Worksheet.
    Dim FSht As Worksheet
    On Error Resume Next
    Set FSht = wb.Worksheets("Ocean")
    If Err.Number = 0 Then
        Application.DisplayAlerts = False
        FSht.Delete
        Application.DisplayAlerts = True
    End If
    On Error GoTo 0
    
    ' Define Target Worksheet.
    Set FSht = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    FSht.Name = "Ocean"
    
    ' Define Source Worksheet.
    Dim Tsht As Worksheet
    Set Tsht = wb.Worksheets("Main")
    With Tsht
        If .AutoFilterMode Then
            .AutoFilterMode = False
        End If
        Const FieldName As String = "Mode"
        Dim FieldNumber As Long
        ' Note that there will be an error if "Mode" cannot be found.
        FieldNumber = Application.Match(FieldName, .Rows(1), 0)
        .Range("A1").AutoFilter Field:=FieldNumber, Criteria1:="Ocean"
        .AutoFilter.Range.Copy FSht.Range("A1")
    End With
    
    MsgBox "Worksheet created, data copied.", vbInformation, "Success"
    
End Sub

这里是另一个使用

Range.Find的选项。我通常尽量避免硬编码行和列。您将看到我在标题行中搜索“Mode”的位置。这允许在不破坏代码的情况下更改列顺序
看到@vbasic208提供的答案后，我会修改代码。我会使用.AutoFilter.Copy
方法，而不是循环遍历每个匹配项。我还喜欢他检查是否已经存在具有所需模式的工作表的方式
祝你好运
Public Sub ExtractDataByMode()

Const mode = "Ocean"

Dim mainWS As Worksheet
Set mainWS = ThisWorkbook.Worksheets("Main")
Dim hdrRow As Range
Set hdrRow = Intersect(mainWS.Rows(1), mainWS.UsedRange)

Dim modeColIdx As Integer
modeColIdx = hdrRow.Find(What:="Mode", lookat:=xlWhole, _
    MatchCase:=False).Column
    
Dim modeColRng As Range
Set modeColRng = Intersect(mainWS.Columns(modeColIdx), mainWS.UsedRange)

Dim firstMatch As Range
Set firstMatch = modeColRng.Find(What:=mode, lookat:=xlWhole, _
    MatchCase:=False)
    
Dim modeWS As Worksheet
Set modeWS = ThisWorkbook.Worksheets.Add( _
    After:=ThisWorkbook.Worksheets( _
    ThisWorkbook.Worksheets.Count))
modeWS.Name = mode
hdrRow.Copy modeWS.Cells(1, 1)

Dim match As Range
Dim nextRow As Integer
Dim matchRow As Range
Set match = firstMatch
nextRow = modeWS.UsedRange.Rows.Count + 1
Do
    Set matchRow = Intersect(mainWS.Rows(match.Row), mainWS.UsedRange)
    matchRow.Copy modeWS.Cells(nextRow, 1)
    Set match = modeColRng.FindNext(match)
    nextRow = modeWS.UsedRange.Rows.Count + 1

Loop While match.Address <> firstMatch.Address

End Sub

Public Sub-ExtractDataByMode（）
Const mode=“海洋”
将mainWS设置为工作表
Set mainWS=ThisWorkbook.Worksheets（“Main”）
Dim hdrRow As范围
设置hdrRow=Intersect（mainWS.Rows（1），mainWS.UsedRange）
Dim MODECLIDX为整数
modeColIdx=hdrRow.Find（What:=“Mode”，lookat:=xlother_
MatchCase:=False）。列
Dim modeColRng As范围
Set modeColRng=Intersect（mainWS.Columns（modeColIdx），mainWS.UsedRange）
将firstMatch设置为范围
设置firstMatch=modeColRng.Find（What:=mode，lookat:=xlother_
匹配案例：=假）
将调制解调器设置为工作表
Set modeWS=此工作簿。工作表。添加（_
之后：=此工作簿。工作表（_
此工作簿。工作表。计数）
modeWS.Name=mode
hdrRow.Copy modeWS.Cells（1,1）
暗匹配范围
Dim nextRow为整数
暗匹配行作为范围
Set match=firstMatch
nextRow=modeWS.UsedRange.Rows.Count+1
做
Set matchRow=Intersect（mainWS.Rows（match.Row），mainWS.UsedRange）
matchRow.Copy modeWS.Cells（下一步，1）
Set match=modeColRng.FindNext（匹配）
nextRow=modeWS.UsedRange.Rows.Count+1
匹配时循环。地址firstMatch。地址
端接头
我认为答案将基于您的数据集。您希望工作表中有多少行？我这样问的原因是，通常建议从下至上删除行。但是，如果工作表中有超过500k+行，这可能需要一些时间。另外，如果您使用过滤器，这种方法将不起作用。所以您可以使用数组方法（在数组中获取数据，从数组中删除数据并将其放回工作表中）。同样，如果你有大数据集，你可能需要考虑数组和<代码>范围的组合。非常感谢@VBasic2008。。。谢谢你的帮助。。。。再次感谢。我们是否有可能将列名改为“Mode”而不是14，以防列发生变化时不会出现任何错误。14是N列范围（“A1”）。自动筛选字段：=14，标准1:=“Ocean”@JaySameer:我已根据您的要求添加了另一个版本。非常感谢@BoilermakerRVHi，它正确地创建了一个名为Ocean的新表。。。。但是，当它继续进行下一个循环时，它会变得太慢，无法执行或在下一个循环中执行，这需要2-3分钟。上面的代码工作正常，但在这个模块结束后，它会挂起大约4-5分钟，然后进一步循环。我对它进行了测试，测试结果很好，但只有28行随机生成的整数。我认为.AutoFilter.Copy
选项在处理更大的数据集时可能会更好。或者是否可以像创建一个名为“Ocean”的新工作表一样！它从列模式中选择值为“Ocean”，并删除其余所有数据，仅将与模式Ocean对应的数据保留在同一“Main”表中。