Vba 输入百分比后如何将Excel行拆分为两张表

我有一个100或999/任意随机数的数据集，我希望在弹出对话框中提取X%X可以在1-99行之间

#   Header  Header 2
1     A       Z
2     2       Y
3     C       X
4     D       3
5     E 
6     F       d
7       
8     H       1
9     I       8
10    J       9

理想情况下，在弹出框中输入20后，我希望有2张新工作表的输出，如下所示

需考虑的条件：

行和列的总数可以是偶数或奇数

不同工作簿的工作表名称可能不同

它应该能够保存在主宏启用的excel中，并跨多个应用程序使用

我修改了乔的密码谢谢！但我的工作簿在粗线处似乎崩溃了

    Public Sub SplitWbByPercentage()
    Dim inputNum As Long
    Dim firstColumn As Long
    Dim headerRow As Long
    Dim cutoffRow As Long
    Dim lastRow As Long
    Dim startingRows As Long
    Dim beforeWorksheet As Worksheet
    Dim afterWorksheet As Worksheet
    Dim x As Long

    Application.ScreenUpdating = False
    inputNum = InputBox("Please enter First File Percentage: ")

    Set wbOrig = ActiveWorkbook
    Set ThisSheet = wbOrig.ActiveSheet

    firstColumn = ThisSheet.UsedRange.Column
    headerRow = 1
    lastRow = ThisSheet.UsedRange.Rows.Count + headerRow
    startingRows = lastRow - headerRow 'for the headers
    cutoffRow = Round(startingRows * (inputNum / 100), 0) + headerRow

    Set beforeWorksheet = Worksheets.Add()
    Set afterWorksheet = Worksheets.Add()

    beforeWorksheet.Rows(headerRow).EntireRow.Value = ThisSheet.Rows(headerRow).EntireRow.Value
    afterWorksheet.Rows(headerRow).EntireRow.Value = ThisSheet.Rows(headerRow).EntireRow.Value


    For x = headerRow + 1 To cutoffRow
        Set wb = Workbooks.Add
        **beforeWorksheet.Rows(x).EntireRow.Value = ThisSheet.Rows(x).EntireRow.Value**

        wb.SaveAs wbOrig.Path & "\Data 1" & WorkbookCounter
        wb.Close
    Next

    For x = cutoffRow + 1 To lastRow
        Set wb = Workbooks.Add
        afterWorksheet.Rows(headerRow + x - cutoffRow).EntireRow.Value = ThisSheet.Rows(x).EntireRow.Value
        wb.SaveAs wbOrig.Path & "\Data 2" & WorkbookCounter
        wb.Close
    Next

    Application.ScreenUpdating = True

End Sub

---

既然你在问题上加了标签，我假设你至少对宏很熟悉，所以我想出了一个宏，它可以满足你的需要

编辑-根据附加要求更新代码。新代码弹出一个输入框，然后将数据拆分为两个新工作簿，保留原始工作簿

编辑2-根据提供的示例文件更新代码。新代码在整个工作表上复制，然后删除与所需行相对应的行，以帮助在Excel中使用内存

Option Explicit

Public Sub SplitWbByPercentage()
    Dim wbOrig As Workbook
    Dim ThisSheet As Worksheet
    Dim wbOutput1 As Workbook
    Dim wsOutput1 As Worksheet
    Dim wbOutput2 As Workbook
    Dim wsOutput2 As Worksheet
    Dim inputNum As Long
    Dim firstColumn As Long
    Dim headerRow As Long
    Dim lastRow As Long
    Dim rowCount As Long
    Dim cutoffRow As Long
    Dim x As Long

    Application.ScreenUpdating = False
    inputNum = InputBox("Please enter First File Percentage: ")

    Set wbOrig = ActiveWorkbook
    Set ThisSheet = wbOrig.ActiveSheet

    firstColumn = ThisSheet.UsedRange.Column
    headerRow = ThisSheet.UsedRange.Row
    lastRow = ThisSheet.UsedRange.Rows.Count + headerRow

    rowCount = lastRow - headerRow 'for the headers
    cutoffRow = Round(rowCount * (inputNum / 100), 0) + headerRow

    ' Output Workbook 1
    ThisSheet.Copy
    Set wbOutput1 = ActiveWorkbook
    Set wsOutput1 = wbOutput1.Worksheets(1)
    wsOutput1.Range(wsOutput1.Rows(cutoffRow + 1), wsOutput1.Rows(lastRow)).Delete
    wbOutput1.SaveAs wbOrig.Path & "\Data 1"
    wbOutput1.Close

    ' Output Workbook 2
    ThisSheet.Copy
    Set wbOutput2 = ActiveWorkbook
    Set wsOutput2 = wbOutput2.Worksheets(1)
    wsOutput2.Range(wsOutput2.Rows(headerRow + 1), wsOutput2.Rows(cutoffRow)).Delete
    wbOutput2.SaveAs wbOrig.Path & "\Data 2"
    wbOutput2.Close

    Application.ScreenUpdating = True

End Sub

---

我试图按如下方式修改代码，但错误下标超出了范围。你能提出建议吗？感谢公共子拆分百分比Dim inputNum As Long inputNum=INPUTBOX请输入从1到99的百分比：Dim STARTING工作表作为工作表集合STARTINGWORKSHEETS SHEET1 Dim FIRSTER Column As Long FIRSTCLUMN=STARTINGWORK.UsedRange.Column Dim headerRow As Long Dim CUTCOFFROW LOW As Long FIRST Dim FIRSTALLlastRow，只要Long headerRow=1，您的评论似乎被切断了。当您得到下标超出范围错误时，哪一行代码被突出显示？感谢您的时间，我是Excel VBA的新手。下标超出范围出现在行集合开始工作表=工作表Sheets1处。它可能是引用吗？很可能是因为工作簿没有名为Sheet1的工作表。只需将引号内的文本更改为数据所在工作表的名称，您就可以了。嗨，Joe，我尝试按上述方式编辑代码，可以帮助检查，因为我希望它在不编辑原始工作簿的情况下创建新工作簿。谢谢