VBA 用於過濾的宏，從列中復制指定值並創建然后粘貼到具有該列名稱的新工作表中

Question

我對 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對應的數據並刪除rest ...請幫忙......

Answer 1

自動過濾復制

這將刪除工作表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

編輯：

• OP 想要用其 header：“模式”來標識標准列，而不是列N (14)。

編輯代碼

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

這是使用Range.Find的另一個選項。 我通常盡量避免對行和列進行硬編碼。 您將看到我在 header 行中搜索“模式”的位置。 這允許在不破壞代碼的情況下更改列順序。

看到@VBasic2008 提供的答案后，我會修改我的代碼。 我會使用.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