Sub Разбить_по_плантациям()
    Dim LastRow As Long, Rng As Range, Coll As New Collection, arrData, iCell As Range, Counter As Long
    
    If MsgBox("Разбить таблицу на плантациям?", vbQuestion + vbYesNo, "Вопрос") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    With Worksheets("Лист1")
        If .FilterMode = True Then .ShowAllData
        .Cells.EntireColumn.Hidden = False
        LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        arrData = .Range("B3:B" & LastRow).Value
        
        On Error Resume Next
        For i = 1 To UBound(arrData)
            Coll.Add arrData(i, 1), arrData(i, 1)
        Next i
        On Error GoTo 0
        .Range("B2").Select
        For i = 1 To Coll.Count
            .Activate
            If .FilterMode = True Then .ShowAllData
            .Cells.EntireColumn.Hidden = False
            .ListObjects("Таблица1").Range.AutoFilter Field:=1, Criteria1:=Coll.Item(i)
            For Each iCell In .UsedRange.Rows(1).Cells
                If iCell.Value = "x" Then iCell.EntireColumn.Hidden = True
            Next
            Counter = Counter + 1
            Worksheets.Add after:=Worksheets(Sheets.Count)
            ActiveSheet.Name = Coll.Item(i)
            .Range("B2").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Range("A1")
            Rows(1).Delete
            Rows(1).Font.Bold = True
            Range("B2").CurrentRegion.Borders.LineStyle = 1
            Columns("A:Z").AutoFit
        Next i
        .Activate
        If .FilterMode = True Then .ShowAllData
        .Cells.EntireColumn.Hidden = False
    End With
    Application.ScreenUpdating = True
    MsgBox "Разбивка на плантациям завершена! Создано " & Counter & " листов!", vbInformation, "Конец"
End Sub

ActiveSheet.Name = Coll.Item(i)

ActiveSheet.Name = Replace(Coll.Item(i), "/", "_")