VBA代码：如何根据列数据复制行和创build表格从MS Excel

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

所以如果你注意到有10行有4种types的办公室：Office-A，Office-B，Office-C，Office-D（等等，可能是更多的办公室types）。所以我想要一个VBA代码根据OFFICE列中办公室types的数量dynamic创build新的工作表，并将与相应办公室types相匹配的行移动到新工作表中。对于此处，将查看OFFICE列并创build4个新工作表，因为有4个types的数据和移动相应的行到这些sheets.Please帮我做到这一点。谢谢

Answer 1

尝试这个：

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 

Answer 2

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

 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