根据条件复制范围，然后dynamic创build一个包含它的新工作表
我有一个带有值的表单，我想要的是F列中的每个唯一值将一个表单命名为该表单，并将所有这些行复制到新表单中。
这段代码看起来很接近，但是我需要它用每个标准（个人）制作一张新的工作表，
Sub NewSheetData() With Application .ScreenUpdating = False .EnableEvents = False End With Dim Rng As Range, rCell As Range Set Rng = Range([A1], Range("A" & Rows.Count).End(xlUp)) For Each rCell In Range("MyTable") On Error Resume Next With Rng .AutoFilter , field:=1, Criteria1:=rCell.Value .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy _ Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1) .AutoFilter End With On Error GoTo 0 Next rCell Application.EnableEvents = True End Sub 以下三个程序在单独的模块中将在主表中的F列中创build并填充具有唯一值的新工作表
这使用字典和后期绑定是慢的 ：
CreateObject（“Scripting.Dictionary”）早期绑定是快速的 ：VBA编辑器 – > 工具 – > 引用 – >添加Microsoft脚本运行时
Option Explicit Private Const X As String = vbNullString Public Sub GetUniques() Const MAIN_COL As Long = 6 'F '<-------------------- update column number Dim ws As Worksheet, arr As Variant, r As Long, rng As Range, d As Dictionary Dim val As Variant, wsNew As Worksheet, lr As Long, lc As Long Set ws = ThisWorkbook.Worksheets("Sheet1") '<-------------------- update sheet name lr = ws.Cells(ws.Rows.Count, MAIN_COL).End(xlUp).Row lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column Set rng = ws.Range(ws.Cells(1, MAIN_COL), ws.Cells(lr, MAIN_COL)) arr = rng: Set d = New Dictionary For r = 1 To UBound(arr) If Len(arr(r, 1)) > 0 Then val = CleanWsName(CStr(arr(r, 1))) If Not d.Exists(val) Then d.Add val, X End If Next Application.ScreenUpdating = False: Application.DisplayAlerts = False For Each val In d Set wsNew = MakeWS(val) rng.AutoFilter Field:=1, Criteria1:="=" & val ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).Copy With wsNew.Cells(1, 1) .PasteSpecial xlPasteColumnWidths .PasteSpecial xlPasteAll Application.CutCopyMode = False wsNew.Activate: .Cells(1, 1).Select End With Next ws.Activate: ws.Cells(1, 1).Copy: rng.AutoFilter Application.ScreenUpdating = True: Application.DisplayAlerts = True End Sub
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 MakeWS(ByVal wsName As String) As Worksheet Dim ws As Worksheet, result As Boolean, activeWS As Worksheet, id As Long With ThisWorkbook If .Worksheets.Count = 1 And .Worksheets(1).Name = wsName Then Exit Function id = IIf(ActiveSheet.Index = 1, ActiveSheet.Index + 1, ActiveSheet.Index - 1) Set activeWS = ActiveSheet If activeWS.Name = wsName Then Set activeWS = .Worksheets(id) For Each ws In .Worksheets If ws.Name = wsName Then ws.Delete Exit For End If Next Set ws = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)) End With ws.Name = wsName activeWS.Activate Set MakeWS = ws End Function
希望这可以帮助
这个怎么样？ 如果你不需要任何其他的过滤列表，你也可以把它读入一个variables，并select独特的项目到另一个variables，并创build基于后者的工作表？
Sub NewSheets() With Application .ScreenUpdating = False .EnableEvents = False End With Dim vList() Dim vUniqueList() Dim vUniqueCount As Integer Dim vIsUnique As Boolean vList = Range([A1], Range("A" & Rows.Count).End(xlUp)) ReDim vUniqueList(1 To UBound(vList, 1)) vUniqueCount = 0 For n = 1 To UBound(vList, 1) vIsUnique = True For m = 1 To UBound(vList, 1) If vUniqueList(m) = vList(n, 1) Then vIsUnique = False End If Next m If vIsUnique Then vUniqueCount = vUniqueCount + 1 vUniqueList(vUniqueCount) = vList(n, 1) End If Next n For n = 1 To vUniqueCount With Sheets.Add(after:=Sheets(Sheets.Count)) .Name = vUniqueList(n) End With Next n Application.EnableEvents = True End Sub