Блог

Я очень новичок в макросе VBA. Я закодировал приведенный ниже макрос, который фильтрует столбец «N», содержащий «Океан», и копирует соответствующие ему данные. Затем он создает новый лист с именем «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" amp; lRw).AutoFilter Field:=2, Criteria1:="Ocean"
        .AutoFilter.Range.Copy

      End With 
  

Я хочу, чтобы макрос разделял только строки, содержащие Ocean, на новом листе с именем листа «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
  

Редактировать:

• Вместо столбца N (14) OP хочет идентифицировать столбец критериев с его заголовком: «Режим».

Отредактированный код

 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 . Обычно я стараюсь избегать жесткого кодирования строк и столбцов, когда это возможно. Вы увидите, где я искал строку заголовка для «Режима». Это позволяет изменять порядок столбцов без нарушения кода.

Я бы изменил свой код, увидев ответ, предоставленный @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