VBA 用于过滤的宏，从列中复制指定值并创建然后粘贴到具有该列名称的新工作表中

Question

I am very new to VBA macro. I coded the macro below that filters on column "N" containing "Ocean" and copies its corresponding data. Then it creates a new worksheet with the name "Ocean" and pastes the data there.

Or is it possible to filter on column N containing "Ocean" and delete the non-matching data? Please help. Below is my code and excel screenshot for reference.

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 

I want the macro to only split rows containing Ocean in a new sheet, with a sheet name of "Ocean". Or macro should keep only data corresponding to Ocean and delete the rest... Please help...........

Answer 1

AutoFilter Copy

This will delete the worksheet Ocean if it exists. Then it will add a new sheet, name it Ocean and copy the filtered data from worksheet Main to it.

The Code

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

EDIT:

• Instead of column N (14), OP wants to identify the criteria column with its header: "Mode".

Edited Code

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

Answer 2

Here is another option using Range.Find . I generally try to avoid hard coding rows and columns whenever possible. You will see where I've searched the header row for "Mode". This allows the column order to change without breaking the code.

I would modify my code after seeing the answer provided by @VBasic2008. I would use the .AutoFilter.Copy method, rather than looping through each match. I also like how he has checked to see if a sheet with the desired mode already exists.

Good luck!

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