VBA 高级自动筛选 + 根据范围创建新工作表
VBA Advanced AutoFilter + Create new sheets based on range
我需要根据工作表模板中的一系列单元格在工作簿中创建新选项卡。我还想删除与选项卡名称不匹配的数据行。例如，在下面的 table 中，我会有一个名为“2206 - 6”的新选项卡，并且只会保留与之关联的数据，请记住，每次使用宏时，此数据范围都会发生变化。
之前:
之后:
区间数
2206 - 6
6304 - 5
4102 - 20
table 从第 11 行开始，但我需要保留以上所有信息。我有一个接近我想要的高级过滤器宏，但它做了两件我不想做的事情：创建空选项卡和不保留第 11 行以上的信息。
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Offshore Searches")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A11:G20"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And _
Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
我还有一个宏，它根据范围创建标签而不使用高级过滤器，因此每个标签看起来都一样（只是标签名称发生了变化）
Sub CreateWorkSheetByRange()
Dim WorkRng As Range
Dim ws As Worksheet
Dim arr As Variant
On Error Resume Next
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
arr = WorkRng.Value
Sheets("Offshore Searches").Select
Cells.Select
Selection.Copy
Application.ScreenUpdating = False
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
Set ws = Worksheets.Add(after:=Application.ActiveSheet)
ws.Name = arr(i, j)
ActiveSheet.Paste
Range("A1").Select
Next
Next
Application.ScreenUpdating = True
End Sub
有没有一种方法既可以基于范围创建选项卡，又可以同时使用高级过滤器？
对于您在图片中显示的内容，您可以尝试类似的方法来实现...
Sub InsertSheets()
Dim sws As Worksheet, ws As Worksheet
Dim slr As Long, i As Long
Dim Rng As Range, Cell As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sws = Sheets("Sheet1")
If sws.Range("A12").Value = "" Then
MsgBox "No Interval Numbers found on the sheet.", vbExclamation
Exit Sub
End If
slr = sws.Range("A11").End(xlDown).Row
Set Rng = sws.Range("A12:A" & slr)
For Each Cell In Rng
On Error Resume Next
Sheets(Cell.Value).Delete
On Error GoTo 0
sws.Copy after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
ws.Name = Cell.Value
ws.DrawingObjects.Delete
With ws
For i = slr To 12 Step -1
If i <> Cell.Row Then ws.Rows(i).Delete
Next i
End With
Set ws = Nothing
Next Cell
sws.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
另一个选项（已测试）
下面的所有函数，在一个单独的模块中
它复制主要 sheet，删除按钮并使用自动过滤器删除不需要的行
This uses dictionaries and late binding is slow: CreateObject("Scripting.Dictionary")
Early binding is fast: VBA Editor -> Tools -> References -> Add Microsoft Scripting Runtime
Option Explicit
Private Const X As String = vbNullString
Public Sub CreateTabs()
Const FIRST_CELL As String = "Interval Number"
Const LAST_CELL As String = "Vesting Doc Number (LC/RS)"
Dim wb As Workbook, ws As Worksheet, wsNew As Worksheet, d As Dictionary, i As Long
Dim fr As Long, lr As Long, fc As Long, found As Range, rng As Range, val As String
SetDisplay False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Offshore Searches")
Set found = FindCell(ws.UsedRange, FIRST_CELL)
If Not found Is Nothing Then
fr = found.Row + 1
fc = found.Column
End If
Set found = FindCell(ws.UsedRange, LAST_CELL)
If Not found Is Nothing Then lr = found.Row - 1
If fr > 0 And fc > 0 And lr >= fr Then
If Not ws.AutoFilter Is Nothing Then ws.UsedRange.AutoFilter
Set rng = ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc))
Dim arr As Variant, r As Long
arr = rng
Set d = New Dictionary
For r = 1 To UBound(arr)
val = Trim(CStr(arr(r, 1)))
val = CleanWsName(val)
If Not d.Exists(val) Then d.Add r, val
Next
For i = 1 To d.Count
If Not WsExists(d(i)) Then
ws.Copy After:=wb.Worksheets(wb.Worksheets.Count)
Set wsNew = wb.Worksheets(wb.Worksheets.Count)
With wsNew
.Name = d(i): If .Shapes.Count = 1 Then wsNew.Shapes.Item(1).Delete
Set rng = .Range(.Cells(fr - 1, fc), .Cells(lr, fc))
rng.AutoFilter Field:=1, Criteria1:="<>" & d(i), Operator:=xlAnd, Criteria2:="<>"
Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1)
rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete Shift:=xlUp
rng.AutoFilter
End With
End If
Next
End If
ws.Activate
SetDisplay True
End Sub
Public Sub SetDisplay(Optional ByVal status As Boolean = False)
Application.ScreenUpdating = status
Application.DisplayAlerts = status
End Sub
Public Function FindCell(ByRef rng As Range, ByVal celVal As String) As Range
Dim found As Range
If Not rng Is Nothing Then
If Len(celVal) > 0 Then
Set found = rng.Find(celVal, MatchCase:=True)
If Not found Is Nothing Then Set FindCell = found
End If
End If
End Function
Public Function CleanWsName(ByVal wsName As String) As String
Const x = vbNullString
wsName = Trim$(wsName) 'Trim, then remove [ ] / \ < > : * ? | "
wsName = Replace(Replace(Replace(wsName, "[", x), "]", x), " ", x)
wsName = Replace(Replace(Replace(wsName, "/", x), "\", x), ":", x)
wsName = Replace(Replace(Replace(wsName, "<", x), ">", x), "*", x)
wsName = Replace(Replace(Replace(wsName, "?", x), "|", x), Chr(34), x)
If Len(wsName) = 0 Then wsName = "DT " & Format(Now, "yyyy-mm-dd hh.mm.ss")
CleanWsName = Left$(wsName, 31) 'Resize to max len of 31
End Function
Public Function WsExists(ByVal wsName As String) As Boolean
Dim ws As Worksheet
With ThisWorkbook
For Each ws In .Worksheets
If ws.Name = wsName Then
WsExists = True
Exit Function
End If
Next
End With
End Function
假设
- 区间数字格式一致：单位&"-"&周(=B12&"-"&C12)
- 间隔号不超过 31 个字符，并且不包含这些特殊字符：[ ] / \ ? * 。
- 如果是这样，sheet 名称将缩短为 31 个字符
- 并删除了所有提到的特殊字符（Excel 对 Sheet 名称的限制）
- 工作行在单元格 "Interval Number" 之后开始并在 "Vesting Doc Number (LC/RS)"
之前停止
- "Interval Number"和"Vesting Doc Number (LC/RS)"前后没有空格
- 主选项卡名称正好是 "Offshore Searches"，它只包含一个按钮 ("Create Tabs")
我需要根据工作表模板中的一系列单元格在工作簿中创建新选项卡。我还想删除与选项卡名称不匹配的数据行。例如，在下面的 table 中，我会有一个名为“2206 - 6”的新选项卡，并且只会保留与之关联的数据，请记住，每次使用宏时，此数据范围都会发生变化。
之前:
之后:
区间数 2206 - 6 6304 - 5 4102 - 20
table 从第 11 行开始，但我需要保留以上所有信息。我有一个接近我想要的高级过滤器宏，但它做了两件我不想做的事情：创建空选项卡和不保留第 11 行以上的信息。
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Offshore Searches")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A11:G20"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And _
Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
我还有一个宏，它根据范围创建标签而不使用高级过滤器，因此每个标签看起来都一样（只是标签名称发生了变化）
Sub CreateWorkSheetByRange()
Dim WorkRng As Range
Dim ws As Worksheet
Dim arr As Variant
On Error Resume Next
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
arr = WorkRng.Value
Sheets("Offshore Searches").Select
Cells.Select
Selection.Copy
Application.ScreenUpdating = False
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
Set ws = Worksheets.Add(after:=Application.ActiveSheet)
ws.Name = arr(i, j)
ActiveSheet.Paste
Range("A1").Select
Next
Next
Application.ScreenUpdating = True
End Sub
有没有一种方法既可以基于范围创建选项卡，又可以同时使用高级过滤器？
对于您在图片中显示的内容，您可以尝试类似的方法来实现...
Sub InsertSheets()
Dim sws As Worksheet, ws As Worksheet
Dim slr As Long, i As Long
Dim Rng As Range, Cell As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sws = Sheets("Sheet1")
If sws.Range("A12").Value = "" Then
MsgBox "No Interval Numbers found on the sheet.", vbExclamation
Exit Sub
End If
slr = sws.Range("A11").End(xlDown).Row
Set Rng = sws.Range("A12:A" & slr)
For Each Cell In Rng
On Error Resume Next
Sheets(Cell.Value).Delete
On Error GoTo 0
sws.Copy after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
ws.Name = Cell.Value
ws.DrawingObjects.Delete
With ws
For i = slr To 12 Step -1
If i <> Cell.Row Then ws.Rows(i).Delete
Next i
End With
Set ws = Nothing
Next Cell
sws.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
另一个选项（已测试）
下面的所有函数，在一个单独的模块中
它复制主要 sheet，删除按钮并使用自动过滤器删除不需要的行
This uses dictionaries and late binding is slow:
CreateObject("Scripting.Dictionary")Early binding is fast: VBA Editor -> Tools -> References -> Add Microsoft Scripting Runtime
Option Explicit
Private Const X As String = vbNullString
Public Sub CreateTabs()
Const FIRST_CELL As String = "Interval Number"
Const LAST_CELL As String = "Vesting Doc Number (LC/RS)"
Dim wb As Workbook, ws As Worksheet, wsNew As Worksheet, d As Dictionary, i As Long
Dim fr As Long, lr As Long, fc As Long, found As Range, rng As Range, val As String
SetDisplay False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Offshore Searches")
Set found = FindCell(ws.UsedRange, FIRST_CELL)
If Not found Is Nothing Then
fr = found.Row + 1
fc = found.Column
End If
Set found = FindCell(ws.UsedRange, LAST_CELL)
If Not found Is Nothing Then lr = found.Row - 1
If fr > 0 And fc > 0 And lr >= fr Then
If Not ws.AutoFilter Is Nothing Then ws.UsedRange.AutoFilter
Set rng = ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc))
Dim arr As Variant, r As Long
arr = rng
Set d = New Dictionary
For r = 1 To UBound(arr)
val = Trim(CStr(arr(r, 1)))
val = CleanWsName(val)
If Not d.Exists(val) Then d.Add r, val
Next
For i = 1 To d.Count
If Not WsExists(d(i)) Then
ws.Copy After:=wb.Worksheets(wb.Worksheets.Count)
Set wsNew = wb.Worksheets(wb.Worksheets.Count)
With wsNew
.Name = d(i): If .Shapes.Count = 1 Then wsNew.Shapes.Item(1).Delete
Set rng = .Range(.Cells(fr - 1, fc), .Cells(lr, fc))
rng.AutoFilter Field:=1, Criteria1:="<>" & d(i), Operator:=xlAnd, Criteria2:="<>"
Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1)
rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete Shift:=xlUp
rng.AutoFilter
End With
End If
Next
End If
ws.Activate
SetDisplay True
End Sub
Public Sub SetDisplay(Optional ByVal status As Boolean = False)
Application.ScreenUpdating = status
Application.DisplayAlerts = status
End Sub
Public Function FindCell(ByRef rng As Range, ByVal celVal As String) As Range
Dim found As Range
If Not rng Is Nothing Then
If Len(celVal) > 0 Then
Set found = rng.Find(celVal, MatchCase:=True)
If Not found Is Nothing Then Set FindCell = found
End If
End If
End Function
Public Function CleanWsName(ByVal wsName As String) As String
Const x = vbNullString
wsName = Trim$(wsName) 'Trim, then remove [ ] / \ < > : * ? | "
wsName = Replace(Replace(Replace(wsName, "[", x), "]", x), " ", x)
wsName = Replace(Replace(Replace(wsName, "/", x), "\", x), ":", x)
wsName = Replace(Replace(Replace(wsName, "<", x), ">", x), "*", x)
wsName = Replace(Replace(Replace(wsName, "?", x), "|", x), Chr(34), x)
If Len(wsName) = 0 Then wsName = "DT " & Format(Now, "yyyy-mm-dd hh.mm.ss")
CleanWsName = Left$(wsName, 31) 'Resize to max len of 31
End Function
Public Function WsExists(ByVal wsName As String) As Boolean
Dim ws As Worksheet
With ThisWorkbook
For Each ws In .Worksheets
If ws.Name = wsName Then
WsExists = True
Exit Function
End If
Next
End With
End Function
假设
- 区间数字格式一致：单位&"-"&周(=B12&"-"&C12)
- 间隔号不超过 31 个字符，并且不包含这些特殊字符：[ ] / \ ? * 。
- 如果是这样，sheet 名称将缩短为 31 个字符
- 并删除了所有提到的特殊字符（Excel 对 Sheet 名称的限制）
- 工作行在单元格 "Interval Number" 之后开始并在 "Vesting Doc Number (LC/RS)" 之前停止
- "Interval Number"和"Vesting Doc Number (LC/RS)"前后没有空格
- 主选项卡名称正好是 "Offshore Searches"，它只包含一个按钮 ("Create Tabs")