Question

我的数据集为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个新工作表，如下所示。

Output Workbook 1

Output Workbook 2

需要考虑的条件：

总行数＆amp;列可以是偶数或奇数
不同工作簿的工作表名称可能有所不同。
它应该能够保存在启用宏的启用的Excel中并使用。

我修改了Joe的代码（谢谢！）但我的工作簿似乎在粗线上崩溃了。

    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

Answer 1

由于您使用excel-vba标记了问题，我将假设您至少熟悉宏，因此我想出了一个可以满足您需求的宏。

修改 - 根据其他要求更新代码。用于弹出输入框然后将数据拆分为两个新工作簿的新代码，只保留原始工作簿。

编辑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

如何在输入百分比后将Excel行拆分为两个表格

1 个答案: