Фильтрация и копирование отфильтрованных уникальных данных на другой лист;имя листа будет уникальным значением

Question

'У меня есть рабочая тетрадь с листами с данными.Мне нужно отфильтровать уникальный номер и скопировать отфильтрованные данные на другой лист, имя листа будет уникальным номером.

'Я пытался получить все номера и удалить дубликаты, оставшееся должно быть отфильтрованным числом для копирования.

' ошибка в том, что я могу копировать данные на разные листы, но нефильтруется по их уникальному номеру

Sub filter()

Dim i As Integer
Dim ST As String
On Error Resume Next
i = 1
Application.ScreenUpdating = False

Do
ST = Sheets("duplicateshipto").Range("A" & i).Value
If ST <> "" Then
Sheets.Add.Name = ST
With Sheets("Template")
.Select
.Range("C1:BQ4").Select

Selection.Copy
Sheets(ST).Select
Sheets(ST).Range("A1").Select
Sheets(ST).Paste

.Select
ActiveSheet.Range("$A$4:$BU$88").AutoFilter Field:=26, Criteria1:=gsd


.Range("Z4", .Range("BS" & .Rows.Count).End(xlUp)).Select

Range("Z4").Select
Selection.End(xlDown).Select
.Range(Selection, Selection.End(xlDown)).Select
.Range(Selection, Selection.End(xlToRight)).Select
.Range(Selection, Selection.End(xlToRight)).Select
.Range(Selection, Selection.End(xlToRight)).Select
.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets(ST).Select
Sheets(ST).Range("x5").Select
Sheets(ST).Paste
.Select
Range("BQ4").Select
Selection.End(xlDown).Select
.Range(Selection, Selection.End(xlDown)).Select
.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets(ST).Select
Sheets(ST).Range("BO6").Select
Sheets(ST).Paste
.Select
Range("Y4").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
'Range(Selection, Selection.End(xlToLeft)).Select
Selection.Copy
Sheets(ST).Select
Sheets(ST).Range("a5").Select
Sheets(ST).Paste

End With
i = i + 1
End If
Loop Until ST = ""

Application.ScreenUpdating = True


End Sub

Answer 1

По сути, вы пытаетесь сделать что-то под названием Расширенный фильтр .Однако ваш код нуждается в некотором улучшении всех опций выбора (как указано в комментариях).Вот пример макроса, в котором есть несколько компонентов, которые вам понадобятся для того, что вы пытаетесь сделать, например:

• . Он динамически фиксирует диапазон всех заполненных ячеек слева и внизу ячейки.F6.
• Использует зеленый диапазон в качестве фильтра (если не оставить поле F3: H3 пустым)
• Вставляет значения, начиная с ячейки A1, с динамическим числом столбцов на основеколичество столбцов данных.
• Исключая дубликаты с использованием Unique:=True (только один дубликат в выборке)

Перед макросом

После макроса

Код, использованный на иллюстрации выше.

Sub exampleRefresh()
Dim cRng As Range, WS As Worksheet
Set WS = ActiveSheet

With WS
    Set cRng = Sheet1.Range("F6")
    Set cRng = Range(cRng, cRng.End(xlToRight))
    Set cRng = Range(cRng, cRng.End(xlDown))

    Dim fRng As Range
    Set fRng = WS.Range("F2:H3")

    Dim PRNG As Range
    Set PRNG = WS.Range("A1")
    Set PRNG = Range(PRNG, PRNG.Offset(, cRng.Columns.Count - 1))

End With


  cRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=fRng, CopyToRange:=PRNG, Unique:=True


End Sub

Также как тизерMicrosoft собирается развернуть новую функцию Spill .С помощью этой функции, если вы хотите перечислить различные значения столбца, вы можете использовать формулу, например =Unique(A:A), в любой ячейке, и это создаст отдельный список.Нет необходимости в VBA или чрезмерном нажатии!