Question

我有一个工作表，其中包含所有数据。样本结构是这样的（当然列的范围一直到X，行大约是17K）

Column A -- Column B -- Column C -- Column D -- Column E
Name1       stuff       stuff        stuff        stuff
Name1       stuff       stuff        stuff        stuff
Name2       stuff       stuff        stuff        stuff
Name3       stuff       stuff        stuff        stuff

所以我需要添加3个新工作表，每个工作表名为Name1，Name2，Name3，并且所有与该名称对应的行都要复制到相应的工作表中。

我的困境是，如何扫描工作表中A列中每个唯一名称，将名称存储在变量中，以便我可以在其后命名工作表？

我认为像这样的synax会很接近，但并不完美 - 将每个名字的所有数据复制到它自己的工作表中，适当的VBA是什么？

        ThisWorkbook.Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = Blah

    Set rngCopy = ActiveSheet.UsedRange
    Set rngCopy = rngCopy.SpecialCells(XlCellType.xlCellTypeVisible)
    ThisWorkbook.Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = Blah
    rngCopy.Copy ThisWorkbook.Worksheets(Blah).Cells(1, 1)
    Application.CutCopyMode = False
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select

Answer 1

Sub ExtractWorksheets()
    Application.ScreenUpdating = False
    Dim OriginalAddress As String
    Dim OriginalData

    With Worksheets("Sheet1").Range("A1").CurrentRegion
        OriginalData = .Value
        OriginalAddress = .Address

        If Not .AutoFilter Then .AutoFilter

        Do While .Cells(2, 1) <> ""
            .AutoFilter Field:=1, Criteria1:=.Cells(2, 1).Value
            Worksheets.Add After:=ActiveSheet
            ActiveSheet.Name = getCleanWorksheetName(.Cells(2, 1).Value)
            .Copy Destination:=Range("A1")
            .Offset(1).EntireRow.Delete
        Loop

        .Range(OriginalAddress).Value = OriginalData
    End With
    Application.ScreenUpdating = True
End Sub

'VBA Express http://www.vbaexpress.com/kb/getarticle.php?kb_id=1132
Function getCleanWorksheetName(ByRef SheetName As String) As String
    Dim charPairs As Variant, ch As Variant
    charPairs = Array(Array(":", "."), Array("/", "."), Array("\", ""), Array("?", "_"), Array("*", "_"), Array("[", "("), Array("]", ")"))

    For Each ch In charPairs
        If InStr(SheetName, ch(0)) Then SheetName = Replace(SheetName, ch(0), ch(1))
    Next
    getCleanWorksheetName = Left(SheetName, 31)
End Function

将主表格迁移到单张表格

1 个答案: