Question

我对VBA没有经验，但我认为这是实现这一目标的唯一途径。

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

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

我感谢任何帮助。

Answer 1

我得到了这个解决方案如果您需要此解决方案，请给我发送电子邮件。

起初我得到了这种格式：
enter image description here
我创建以下宏代码

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

以下是输出
enter image description here

Answer 2

我编写了一个基于输入数据的VBA（宏）程序。您需要做的就是在另一个工作表的列中提供输入数据。宏将根据每行读取数据并过滤主表，然后根据查找数据生成新的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

Answer 3

请找到以下代码

Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow, nRow, nNextRow As Integer
    Dim strColumnValue As String
    Dim objDictionary As Object
    Dim varColumnValues As Variant
    Dim varColumnValue As Variant
    Dim objExcelWorkbook As Excel.Workbook
    Dim objSheet As Excel.Worksheet
    Dim icol As Long
    Dim l As Long
    Dim headercol As Long
    Dim stroutputfolder As String
    stroutputfolder = "D:\Ba"
    'dim str
    icol = 1
    headercol = 3
    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row

    Set objDictionary = CreateObject("Scripting.Dictionary")

    For nRow = headercol + 1 To nLastRow
        'Get the specific Column
        'Here my instance is "B" column
        'You can change it to your case
        strColumnValue = objWorksheet.Cells(nRow, icol).Value

        If objDictionary.Exists(strColumnValue) = False Then
           objDictionary.Add strColumnValue, 1
        End If
    Next

    varColumnValues = objDictionary.Keys

    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
        'MsgBox (varColumnValues(i))


       If Dir(stroutputfolder, vbDirectory) = vbNullString Then MkDir stroutputfolder
  If CStr(varColumnValue) <> "" Then
    objWorksheet.UsedRange.Offset(headercol - 1, 0).AutoFilter Field:=icol, Criteria1:=CStr(varColumnValue)
    Set objExcelWorkbook = Excel.Application.Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
    objWorksheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
    'strFilename = strOutputFolder & "\" & strItem
    ActiveWorkbook.SaveAs Filename:=stroutputfolder & "\" & CStr(varColumnValue) & ".xlsb", FileFormat:=50
    ActiveWorkbook.Close savechanges:=False
    l = l + 1
  End If
Next
objWorksheet.ShowAllData

MsgBox (l & " files splitted")
End Sub

VBA代码，用于根据列的内容将excel文件拆分为多个工作簿？

3 个答案: