Блог

Главная - Вопросы по программированию - Изменение отфильтрованного столбца в макросе VBA

Изменение отфильтрованного столбца в макросе VBA

#excel #vba

Вопрос:

Я видел здесь макрос, который хорошо работает для фильтрации и копирования данных на новую вкладку. Однако это не работает, когда я пытаюсь изменить отфильтрованный столбец (в данном случае это столбец F, но я хочу изменить его на столбец B). Смотреть ниже:

 Function GetWorksheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetWorksheet = Worksheets(shtName)
End Function

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "Sheet1"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:F" amp; last)

Sheets(sht).Range("F1:F" amp; last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=6, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy

Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x

' Turn off filter
Sheets(sht).AutoFilterMode = False

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

End Sub

Комментарии:

1. Пожалуйста, объясните конкретно, что не работает (непреднамеренное поведение, сообщение об ошибке и т.д.)

2. Одна из потенциальных проблем заключается в том, что если вы измените столбец F на B, у вас будет только диапазон из двух столбцов, и использование Field:=6 не будет работать. Вам придется переключиться на 2.

3. Пожалуйста, отредактируйте вопрос, чтобы ограничить его конкретной проблемой с достаточной детализацией для определения адекватного ответа.

Ответ №1:

Я бы сказал, что если вы хотите, чтобы это можно было повторно использовать для разных листов, тогда был бы полезен еще один уровень абстракции, поэтому вы можете вызывать один и тот же суб, но с разными диапазонами источников:

 Sub Tester()

    With ThisWorkbook.Worksheets("Sheet1")
        FilterRangeToNewSheets .Range("A1:F" amp; .Cells(.Rows.Count, "F").End(xlUp).Row), 6
    End With

End Sub

'Given a range and a column index in that range, add new sheets, one for each
'   set of unique values in the range
Sub FilterRangeToNewSheets(rngToFilter As Range, filterColumnIndex As Long)
    
    Dim vals As Collection, k, wb As Workbook
    
    Set wb = rngToFilter.Worksheet.Parent               'parent workbook
    Set vals = Uniques(rngToFilter.Columns(filterColumnIndex).Offset(1, 0)) 'offset to exclude the header
    
    For Each k In vals
        With rngToFilter
            .AutoFilter
            .AutoFilter Field:=filterColumnIndex, Criteria1:=k
            .SpecialCells(xlCellTypeVisible).Copy
            With wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
                .Name = k
                .Paste Destination:=.Range("A1")
            End With
        End With
    Next k
    rngToFilter.Worksheet.AutoFilterMode = False ' Turn off filter
    Application.CutCopyMode = False
End Sub

'extract all unique values from a range into a dictionary
Function Uniques(rng As Range) As Collection
    Dim col As New Collection, data, c As Range, v
    For Each c In rng.Cells
        v = c.Value
        If Len(v) > 0 Then
            On Error Resume Next 'ignore any duplicate key error
            col.Add v, v
            On Error GoTo 0 'stop ignoring errors
        End If
    Next c
    Set Uniques = col
End Function

Заменил свой Расширенный фильтр на функцию, которая будет возвращать коллекцию, содержащую только уникальные значения.

Метки: