Question

我是VBA的初学者。基本上我需要一个代码，为多个工作表中的每个特定列值生成一个新工作簿。每个工作表中的关键是列组。

原始文件中总共有6张纸，其中包含以下列。 工作表一般数据

位置项目项目经理状态组

工作表费用

位置组项目成本

上个月的工作表成本

上个月的位置组项目成本

工作表问题

位置项目项目经理问题小组

此外，wb中还有另外两张需要转移的纸张，但保持不变。（“概述”和“摘要”）。谢谢。

Answer 1

我在这里有一个草稿，但它自动过滤了“摘要”和“概述”。因此，它们被复制两次到目标wb。

Sub SplitWB（） Application.EnableEvents = False：Application.ScreenUpdating = False：Application.DisplayAlerts = True 错误GoTo清理

Dim ws As Worksheet, wb As Workbook, team
For Each team In getTeams
    Set wb = Workbooks.Add ' create a wb for each team with same # of sheets

    Do Until wb.Worksheets.Count >= ThisWorkbook.Worksheets.Count
        wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.Count)
    Loop

    For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Overview" And ws.Name <> "Summary" Then
        With ws.UsedRange
            .AutoFilter 1, team ' filter to copy only the team's rows
            .Copy wb.Sheets(ws.Index).Range("A1")
            .AutoFilter
        End With
        End If
        wb.Sheets(ws.Index).Name = ws.Name


    Next

    ThisWorkbook.Worksheets("Summary").Copy After:=wb.Sheets(wb.Sheets.Count)

ThisWorkbook.Worksheets（“Overview”）。复制之后：= wb.Sheets（wb.Sheets.Count） wb.SaveAs“项目预算跟踪”＆amp;团队与团队“原来的.xlsx”

    wb.Close False
Next

清理： Application.EnableEvents = True：Application.ScreenUpdating = True：Application.DisplayAlerts = True 结束子

函数getTeams（）'使用字典获取唯一的团队名称 Dim cel As Range，dict As Object 设置dict = CreateObject（“Scripting.Dictionary”）使用ThisWorkbook.Sheets（“Sheet1”） For Each cel In .Range（“A2：A”＆amp; .Cells（.Rows.Count，“A”）。End（xlUp）.Row）如果Len（Trim（cel.Value2））＆gt; 0然后dict（cel.Value2）= 0 下一个结束 getTeams = dict.Keys 结束功能

根据多个工作表中的列值生成新工作簿

1 个答案: