VBA代码根据列的内容将excel文件分割成多个工作簿？ [英] VBA code to split an excel file into multiple workbooks based on the contents of a column?

问题描述

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

我需要向每个销售团队发送报告，但是不想向他们发送其他销售团队的信息。每个工作簿有多个工作表，不同的报告都有一个销售团队列。

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

<我感谢任何帮助。

解决方案

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

 输入Option Explicit 
 Dim personRows As Range'存储找到的所有行
 
 '将数据拆分成单独的列，在
''名称'表上的RepList中定义的名称。 
 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 
 
'在我的情况下，我根据开始的每8个reacords生成新的excel。你可以根据你的需要简单地理解这个逻辑。 
 
对于每个p In Sheets（Names）。Range（RepList）给出输入表和列的名称
如果i = 0那么'我们开始了在memeory中生成新的excel。 
 Workbooks.Add 
设置wb = ActiveWorkbook 
 ThisWorkbook.Activate 
 End If 
 WritePersonToWorkbook wb，p.Value 
i = i + 1'增加计数器达到时间
如果i = 8那么'因为我需要的是在处理每8个uniqe记录后才保存excel表并重新设置处理
 counter2 = counter2 + 1 
 wb.SaveAs ThisWorkbook.Path &安培; \salesdata_& CStr（counter2）'将数据保存在当前目录位置。 
 wb.Close 
设置personRows = Nothing'一旦进程完成了curent excelsheet，将personRows设置为NULL 
i = 0 
如果
下一个p 
 
 Application.ScreenUpdating = True 
设置wb = Nothing 
 End Sub 
 
'写入属于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 
如果不是firstRW是没有而不是IsNull（rw）然后
设置firstRW = rw'我们要添加每个excel表中的第一行。 
 End If 
如果Person = rw.Cells（1，5）然后'我的过滤器工作基于FeederID
如果personRows不是，然后
设置personRows = firstRW 
设置personRows = Union（personRows，rw）
 Else 
设置personRows = Union（personRows，rw）
如果
结束If 
 Next rw 
 personRows.Copy SalesWB.Sheets（1）.Cells（1，1）'在Excel工作表中添加数据。 
 End Sub 
  

I'm not experienced with VBA, but I think it's the only way for this to work.

I need to send a report to each sales team, but don't want to send them the information of other sales team. There are multiple sheets per workbook with different reports which all have a sales team column.

I would like all the sheets to be filtered by sales team, and create a new workbook for each team.

I appreciate any help.

解决方案

I have written a VBA(Macro) program which will work based on Input data. All you need to do is, provide input data in a column in another sheet. Macro will read the data and filter Master Sheet based on each row then it Generate new excel sheet based on find data.

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

这篇关于VBA代码根据列的内容将excel文件分割成多个工作簿？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！