用于将多个工作表合并到一个工作簿的VBA
在PC上运行Excel 2016
我一直在浏览互联网几个星期试图弄清楚，我卡住了。 我的任务是将现有的主文件分成多个工作表，拆分保留工作表的工作簿，但只显示每个销售代表的数据（超过1000名员工，这使得手动任务成为一个巨大的负担）。 主工作簿由3个工作表组成。
我目前有代码编写和工作，需要主工作簿，并拆分我为我们组织中的每个销售代表指定的工作表，并将工作表保存为一个唯一的文件名（下面列出的代码SplitToFiles ），然后运行主文件中的每个工作表。 我会想象有一些方法来循环最初的代码是从写得到去为每个工作表拆分文件，并将其保存为一个工作簿，但我一直无法弄清楚这就是为什么我去了寻找拆分解决scheme的路线，然后重新组合。
现在，我卡住的是获取个人代表的新工作表成为一个工作簿的组合文件与所有这个代表的工作表只有。 我能够放在一起的代码将结合一个文件夹中的所有文件，从而击败我的突破努力（下面列出的子代价单 ）。
我非常感谢任何人的帮助，指出我在这个/这些代码出错的地方。 我真的很想学习！
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