VBA代码：如何基于列数据从MS Excel复制行和创建工作表

Question

我是VBA的新手，并希望根据OFFICE列的值复制以下工作表的行：

因此，如果您注意到有10行具有4种办公室类型：Office-A，Office-B，Office-C，Office-D（依此类推，可能是更多的Office类型）。所以我想要一个VBA代码，根据OFFICE列中办公室类型的数量动态创建尽可能多的新工作表，并将与相应办公室类型匹配的行移动到新工作表中。对于：这里将查看OFFICE列并创建4个新工作表，因为有4种类型数据并将相应的行移动到这些表。请帮助我做到这一点。谢谢

Answer 1

这将为column B唯一数据创建一个新工作表，并将工作表重命名为单元格值。 您可能必须修改代码以适合您的目的。

Sub dave()

Dim dicKey, dicValues, data, lastrow As Long
Dim i As Long, ws As Worksheet, wsDest As Worksheet

    Set ws = ActiveSheet
    lastrow = Cells(Rows.count, 2).End(xlUp).Row
     data = Range("B2:B" & lastrow) ' load data into variable
             With CreateObject("scripting.dictionary")
                    For i = 1 To UBound(data)
                         If .Exists(data(i, 1)) = False Then
                            dicKey = data(i, 1) 'set the key
                            dicValues = data(i, 1) 'set the value for data to be stored
                            .Add dicKey, dicValues
                            Set wsDest = Sheets.Add(After:=Sheets(Worksheets.count))
                             wsDest.Name = data(i, 1)
                            Sheets(data(i, 1)).Cells(1, 1).Value = ws.Cells(i + 1, 2).Value
                         End If
                      Next i
              End With
End Sub

Answer 2

尝试这个：

Option Explicit

Sub main()
    Dim cell As Range, dataRng As Range

    With Worksheets("Offices").UsedRange '<--| change "Offices" with your actual sheet name
        Set dataRng = .Cells
        With .Offset(, .Columns.Count).Resize(, 1)
            .Value = .Parent.Columns("B").Value
            .RemoveDuplicates Columns:=Array(1), Header:=xlYes
            With .SpecialCells(XlCellType.xlCellTypeConstants)
                For Each cell In .Offset(1).Resize(.Rows.Count - 1)
                    AddSheet cell.Value
                    With dataRng
                        .AutoFilter field:=2, Criteria1:=cell.Value
                        .SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets(cell.Value).Cells(1, 1)
                    End With
                Next cell
            End With
            .Parent.AutoFilterMode = False
            .Clear
        End With
    End With
End Sub

Sub AddSheet(shtName As String)
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(shtName)
    On Error GoTo 0
    If ws Is Nothing Then Worksheets.Add.Name = shtName
End Sub