#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
Заменил свой Расширенный фильтр на функцию, которая будет возвращать коллекцию, содержащую только уникальные значения.