VBA用于将多个工作表合并到一个工作簿中

在PC上运行Excel 2016

几周来，我一直在浏览互联网，试图弄明白这一点，但我被卡住了。我的任务是获取一个包含多个工作表的现有主文件，并拆分工作簿，保留工作表，但只显示每个销售代表的数据（我们的员工中有1000多人，这使得此手动任务成为一个巨大的负担）。主工作簿由3个工作表组成

我目前编写了代码，并正在使用该代码提取主工作簿，拆分出我为组织中的每个销售代表指定的工作表，并将工作表保存为唯一的文件名（下面列出的代码为subSplitToFiles），然后针对主文件中的每个工作表运行该文件名。我想有一种方法可以循环初始代码，它是从get-go编写的，可以为每个工作表拆分文件并将其保存为一个工作簿，但我一直没有弄清楚这一点，这就是为什么我一直在寻找拆分然后重新组合的解决方案

现在，我陷入困境的地方是将单个代表的新工作表与此代表的所有工作表合并到一个包含1个工作簿的文件中。我能够组合的代码将把所有文件合并到一个文件夹中，从而挫败了我的突破努力（下面列出的代码为subgetsheets）

我将非常感谢任何人的帮助，指出我在这/这些代码方面的错误。我真的很想学习

---

公共子拆分文件（）
将osh设置为工作表
暗淡无光
如长
昏暗的伊弗斯特罗一样长
暗淡的头发和长的头发一样长
Dim iStartRow尽可能长
我的船头很长
将SectionName设置为字符串
变暗rCell As范围
将owb设置为工作簿
将sFilePath设置为字符串
Dim I以整数形式计数
iCol=Application.InputBox（“输入用于拆分的列号”，“选择列”，2，，，，，1）”。开始列的位置因工作表而异
iRow=Application.InputBox（“输入起始行号（跳过标题）”，“选择行”，5，，，，1）”起始行位置因工作表而异
iFirstRow=iRow
设置osh=工作簿（“主工作簿.xlsm”）。工作表（1）的工作表编号将更新为2和3，以便为主工作簿上的每个工作表运行。
设置owb=Application.active工作簿
iTotalRows=osh.UsedRange.Rows.Count
sFilePath=Application.ActiveWorkbook.Path
如果Dir（sFilePath+“\Split”，vbDirectory）=“”，则
MkDir sFilePath+“\Split”
如果结束
Application.EnableEvents=False
Application.ScreenUpdating=False
做
设置rCell=osh.单元格（iRow、iCol）
sCell=Replace（rCell.Text，“，”）
如果sCell=“”或（rCell.Text=sSectionName和iStartRow 0）或InStr（1，rCell.Text，“total”，vbTextCompare）0，则
其他的
如果iStartRow=0，则
sSectionName=rCell.Text
iStartRow=iRow
其他的
iStopRow=iRow-1
复印纸osh、iFirstRow、iStartRow、iStopRow、iTotalRows、sFilePath、sSectionName、owb.fileFormat
iCount=iCount+1
iStartRow=0
iStopRow=0
iRow=iRow-1
如果结束
如果结束
如果iRowISTOROW，则
DeleteRows灰，iStopRow+1，iTotalRows
如果结束
如果iStartRow>iFirstRow，则
删除行灰、iFirstRow、iStartRow-1
如果结束
灰分。单元格（1，1）。选择
sSectionName=Replace（sSectionName，“/”，“”）
sSectionName=Replace（sSectionName，“，”）
sSectionName=Replace（sSectionName，“：”，“”）
sSectionName=Replace（sSectionName，“=”，“”）
sSectionName=Replace（sSectionName，“*”，“”）
sSectionName=Replace（sSectionName，“.”，“”）
sSectionName=Replace（sSectionName，“？”，“”）
ash.SaveAs sFilePath+“\Split”+“订单报告”+s操作名，文件格式
设置awb=ash.Parent
awb.Close SaveChanges:=False
端接头
子表（）
Path=“C:\Users\Jessica\Desktop\Split”
Filename=Dir（路径&“*.xlsm”）
文件名“”时执行此操作
工作簿。打开文件名：=路径和文件名，只读：=真
对于ActiveWorkbook.Sheets中的每个工作表
Sheet.Copy After:=此工作簿.Sheets（1）
下一页
工作簿（文件名）。关闭
Filename=Dir（）
环
端接头

您需要提供示例数据和预期结果。此外，您让它听起来像您最初有一个单一的主工作簿，已经有了您需要的所有信息。你能澄清一下吗？你需要提供样本数据和预期结果。此外，您让它听起来像您最初有一个单一的主工作簿，已经有了您需要的所有信息。你能澄清一下吗？

Public Sub SplitToFiles()
    Dim osh As Worksheet
    Dim iRow As Long
    Dim iCol As Long
    Dim iFirstRow As Long
    Dim iTotalRows As Long
    Dim iStartRow As Long
    Dim iStopRow As Long
    Dim sSectionName As String
    Dim rCell As Range
    Dim owb As Workbook
    Dim sFilePath As String
    Dim iCount As Integer
    iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1) 'The starting column position varies from worksheet to worksheet
    iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1) 'The starting row position varies from worksheet to worksheet
    iFirstRow = iRow
    Set osh = Workbooks("Master Workbook.xlsm").Worksheets(1) 'Worksheet number is updated to 2 and 3 to be run for each worksheet on the master workbook.
    Set owb = Application.ActiveWorkbook
    iTotalRows = osh.UsedRange.Rows.Count
    sFilePath = Application.ActiveWorkbook.Path
    If Dir(sFilePath + "\Split", vbDirectory) = "" Then
        MkDir sFilePath + "\Split"
    End If
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Do
        Set rCell = osh.Cells(iRow, iCol)
        sCell = Replace(rCell.Text, " ", "")
        If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        Else
            If iStartRow = 0 Then
                sSectionName = rCell.Text
                iStartRow = iRow
            Else
                iStopRow = iRow - 1
                CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
                iCount = iCount + 1
                iStartRow = 0
                iStopRow = 0
                iRow = iRow - 1
            End If
        End If
        If iRow < iTotalRows Then
            iRow = iRow + 1
        Else
            iStopRow = iRow
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1
            Exit Do
        End If
    Loop
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)
    Dim rngRange As Range
    Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
    rngRange.Select
    rngRange.Delete
End Sub
Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
    Dim ash As Worksheet
    Dim awb As Workbook
    osh.Copy
    Set ash = Application.ActiveSheet
    If iTotalRows > iStopRow Then
        DeleteRows ash, iStopRow + 1, iTotalRows
    End If
    If iStartRow > iFirstRow Then
        DeleteRows ash, iFirstRow, iStartRow - 1
    End If
    ash.Cells(1, 1).Select
    sSectionName = Replace(sSectionName, "/", " ")
    sSectionName = Replace(sSectionName, "", " ")
    sSectionName = Replace(sSectionName, ":", " ")
    sSectionName = Replace(sSectionName, "=", " ")
    sSectionName = Replace(sSectionName, "*", " ")
    sSectionName = Replace(sSectionName, ".", " ")
    sSectionName = Replace(sSectionName, "?", " ")
    ash.SaveAs sFilePath + "\Split" + "Order Report " + sSectionName, fileFormat
    Set awb = ash.Parent
    awb.Close SaveChanges:=False
End Sub


Sub getsheets()
    Path = "C:\Users\Jessica\Desktop\Split"
    Filename = Dir(Path & "*.xlsm")
    Do While Filename <> ""
        Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
        For Each Sheet In ActiveWorkbook.Sheets
            Sheet.Copy After:=ThisWorkbook.Sheets(1)
        Next Sheet
        Workbooks(Filename).Close
        Filename = Dir()
    Loop
End Sub