Question

在PC上运行Excel 2016

我一直在浏览互联网几周试图解决这个问题而且我被卡住了。我的任务是将现有的主文件与多个工作表分开并分割保留工作表的工作簿，但仅显示每个销售代表的数据（在我们的员工中超过1000，这使得这个手动任务成为一个巨大的负担）。主工作簿由3个工作表组成。

我目前编写代码并使用主要工作簿并拆分我为组织中每个销售代表指定的工作表，并将工作表保存为唯一的文件名（下面列出的代码为 SplitToFiles ）然后我为主文件中的每个工作表运行。我想有一些方法可以循环初始代码，它是从get get中为每个工作表分割文件并将其保存为一个工作簿但是我无法弄清楚这就是为什么我去了寻找分裂解决方案然后重新组合的途径。

现在我陷入困境的是将个人代表的新工作表转换为1个工作簿的组合文件，并且只有该代表的所有工作表。我能够放在一起的代码将把文件夹中的所有文件组合在一起，从而打败我的突破工作（下面列出的代码为得到表格）。

我非常感谢任何人的帮助，指出我/这些代码出错的地方。我真的很想学！

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

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

0 个答案: