VBA代码根据列的内容将Excel文件分成多个工作簿？

我没有VBA的经验，但我认为这是唯一的方法来工作。

我需要向每个销售团队发送一份报告，但不想将其他销售团队的信息发送给他们。 每个工作簿有多个工作表，其中包含不同的报表，这些报表都有销售小组专栏。

我希望销售团队过滤所有表单，并为每个团队创build一个新的工作簿。

我感谢任何帮助。

Answer 1

我有这个解决scheme。
如果您需要此解决scheme，请发送电子邮件给我。

起初我得到这种格式：

我创build了以下macros代码

Option Explicit Dim MainWorkBook As Workbook Dim NewWorkBook As Workbook Sub ExportWorksheet() Dim Pointer As Long Set MainWorkBook = ActiveWorkbook Range("E2").Value = MainWorkBook.Sheets.Count Application.ScreenUpdating = False 'enhance the performance For Pointer = 2 To MainWorkBook.Sheets.Count Set NewWorkBook = Workbooks.Add MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1) Application.DisplayAlerts = False NewWorkBook.Sheets(1).Delete Application.DisplayAlerts = True With NewWorkBook .SaveAs Filename:="C:\Users\lengkgan\Desktop\Testing\" & MainWorkBook.Sheets(Pointer).Name & ".xls" 'you may change to yours End With NewWorkBook.Close SaveChanges:=True Next Pointer Application.ScreenUpdating = True Range("D5").Value = "Export Completed" End Sub 

以下是输出

Answer 2

我写了一个基于input数据的VBA（macros）程序。 所有你需要做的是，提供input数据在另一张表中的一列。 macros将读取数据并根据每行过滤主表，然后根据查找数据生成新的Excel表。

 enter Option Explicit Dim personRows As Range 'Stores all of the rows found 'Split data into separate columns baed on the names defined in 'a RepList on the 'Names' sheet. Sub SplitSalesData() Dim wb As Workbook Dim p As Range Dim counter2 As Integer Dim i As Integer counter2 = 0 i = 0 Application.ScreenUpdating = False ' in my case i am generating new excel based on every 8 reacords from begining. You can simplyfy this logic based on your need. For Each p In Sheets("Names").Range("RepList") ' Give the name of your input sheet and column If i = 0 Then ' We are starting, so generate new excel in memeory. Workbooks.Add Set wb = ActiveWorkbook ThisWorkbook.Activate End If WritePersonToWorkbook wb, p.Value i = i + 1 ' Increment the counter reach time If i = 8 Then ' As my need is after processing every 8 uniqe record just save the excel sheet and reset the processing counter2 = counter2 + 1 wb.SaveAs ThisWorkbook.Path & "\salesdata_" & CStr(counter2) ' save the data at current directory location. wb.Close Set personRows = Nothing ' Once the process has completed for curent excelsheet, set the personRows as NULL i = 0 End If Next p Application.ScreenUpdating = True Set wb = Nothing End Sub 'Writes all the data rows belonging to a RepList Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _ ByVal Person As String) Dim rw As Range Dim firstRW As Range For Each rw In UsedRange.Rows If Not Not firstRW Is Nothing And Not IsNull(rw) Then Set firstRW = rw ' WE want to add first row in each excel sheet. End If If Person = rw.Cells(1, 5) Then ' My filter is working based on "FeederID" If personRows Is Nothing Then Set personRows = firstRW Set personRows = Union(personRows, rw) Else Set personRows = Union(personRows, rw) End If End If Next rw personRows.Copy SalesWB.Sheets(1).Cells(1, 1) ' Adding data in Excel sheet. End Sub