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

Question

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

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

地点项目项目经理的资格组

表费用

位置组项目成本

表费用上个月

位置集团项目成本上个月

表问题

地点项目项目经理问题小组

此外，还有在WB需要被转移很好，但保持原样其他两个表。 （“概述”和“摘要”）。 谢谢。

Answer 1

在这里我有一个草稿，但它自动筛选工作表“摘要”和“概述”。因此它们被复制两次到目的地wb。

子SplitWB（） Application.EnableEvents =假：Application.ScreenUpdating =假：Application.DisplayAlerts =真 对错误转到清理

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（ “概览”）副本后： = wb.Sheets（wb.Sheets.Count） wb.SaveAs “项目预算跟踪” &队& “的.xlsx”

wb.Close False 
Next 

清理： 个Application.EnableEvents = TRUE：Application.ScreenUpdating = TRUE：Application.DisplayAlerts =真 结束小组

功能getTeams（）'使用字典 昏暗CEL量程，字典作为对象 集字典得到唯一的队名=“Create”（“Scripting.Dictionary”） With ThisWorkbook.Sheets（“Sheet1”） For Each cel In .Range（“A2：A”& .Cells（.Rows.Count，“A”）.End（xlUp） .Row） 如果len（修剪（cel.Value2））> 0，则字典（cel.Value2）= 0 接着 尾随着 getTeams = dict.Keys 端功能