Question

Excel主表在Col A中按成本中心列出项目，然后在Col B中按部门列出。我需要创建一个动态范围，可以通过特定部门识别每行中的项目;然后，为所识别的项目选择那些行;然后，将这些行复制并粘贴到为B列中的各个部门命名的新工作表中。

假设Dept总是在B列，这是我迄今为止提出的代码。此代码在Col B中找到一个新的Dept.并添加一个具有相同Name的新工作表。我需要一个代码来选择具有相同Dept Name的行;复制选择，然后将该信息粘贴到新创建的工作表上。有没有人对这种做法有任何建议？

Sub Breakout1975()
Dim I As String
Dim First As Variant

Range("B1").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(1, 0).Select

  If ActiveCell.Value <> Selection.Offset(-1, 0) Then
    MsgBox ("The Program has identified a new Dept. in Cell:" & " " &_
    ActiveCell.Address)
    MsgBox (Selection)'just using this as a check for myself
    Sheets.Add.Name = Selection
    Worksheets("sheet1").Select 'advance to variable later
  End If
Loop

End Sub

Answer 1

如果您决定插入标题行，此例程使用.AutoFilter来分割数据。此外，它还使用了Scripting.Dictionary的唯一键属性。您必须进入VBE的工具►参考，并将 Microsoft Scripting Runtime 添加到您的项目中。

Sub Split_Depts()
    Dim b As Long, w As Long
    Dim dDEPTs As New Scripting.Dictionary
    dDEPTs.CompareMode = TextCompare
    For w = 2 To Sheets.Count
        dDEPTs.Add Key:=Sheets(w).Name, Item:=w ' no need to check if dDEPTs.Exists, ws names are unique
    Next w
    With Sheet2.Cells(1, 1).CurrentRegion  'change to your own sheet codename
        For b = 2 To .Rows.Count
            If Not dDEPTs.Exists(Trim(.Cells(b, "B").Value)) Then
                Sheets.Add after:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = Trim(.Cells(b, "B").Value)
                dDEPTs.Add Key:=Sheets(Sheets.Count).Name, Item:=Sheets.Count
                If .AutoFilter Then .AutoFilter
                .AutoFilter Field:=2, Criteria1:=dDEPTs.Keys(UBound(dDEPTs.Keys))
                .Cells.Copy Destination:=Sheets(Sheets.Count).Cells(1, 1)
                .AutoFilter
            End If
        Next b
    End With
CleanUp:
    dDEPTs.RemoveAll
    Set dDEPTs = Nothing
End Sub

如果你想要它更快，你可以添加线来关闭屏幕更新，禁用事件，计算等。

动态范围选择＆amp;新工作表

1 个答案: