如何在輸入百分比後將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