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

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在弹出开箱I键有2名新的工作表的输出如下。

Output Workbook 1

Output Workbook 2

条件要考虑：

1. 行的总数&列可以是偶数或奇数

2. 表名称可以针对不同的变化工作簿。

3. 它应该能够保存在主宏启用excel中并在整个范围内使用。

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

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