我試圖將一個包含 120 條記錄的檔案拆分為每個最多 50 條記錄的檔案。所以期望它應該生成 2 個具有 50 條記錄的檔案和 1 個具有 20 條記錄的檔案，但我得到的是 51 個記錄的 3 個檔案，最后有 1 個空檔案，用于第三個檔案中的前 2 個和 31 個空行。
Sub SplitAndSaveFile()
Dim myRow As Long, myBook As Workbook, splitCount As Integer, thisWBName As String, splitCountStr As String, spaceRange As Range
lastRow = ThisWorkbook.Sheets("Data").Cells(rows.Count, 1).End(xlUp).Row
splitCount = 1
splitCountStr = CStr(splitCount)
thisWBName = Replace(ThisWorkbook.Name, ".xlsm", "") "_Part"
For myRow = 4 To lastRow Step 50
Set myBook = Workbooks.Add
ThisWorkbook.Sheets("Data").rows(myRow & ":" & myRow 49).EntireRow.Copy myBook.Sheets("Sheet1").Range("A1")
myBook.SaveAs (ThisWorkbook.Path "\" thisWBName splitCountStr ".txt"), FileFormat:=xlText
myBook.Close
splitCount = splitCount 1
splitCountStr = CStr(splitCount)
Next myRow
MsgBox ("File(s) generated.")
End Sub
uj5u.com熱心網友回復：
按行數匯出資料
部分快速修復
- 您的代碼似乎在我的測驗資料上運行良好，因此，考慮到您對問題的描述，我唯一能想到的是，在列中，
A有一些公式在底部評估為空字串，而您不想這樣做包括。要解決此問題，您可以使用以下Find方法：
Dim LastRow As Long: LastRow = ThisWorkbook.Worksheets("Data") _
.Columns("A").Find("*", , xlValues, , , xlPrevious)
- 不幸的是，您也沒有考慮將少于 50 條記錄復制到最后一個作業簿的情況。看看它是如何在“深入”解決方案中處理的。
深入
- 這會將作業表中的記錄匯出到新作業簿，保存為文本，最多包含 50 行。
Option Explicit
Sub SplitAndSaveFile()
Const ProcName As String = "SplitAndSaveFile"
Dim dwbCount As Long ' Generated Workbooks Count
On Error GoTo ClearError
' Source
Const swsName As String = "Data"
Const sCol As String = "A"
Const sfRow As Long = 4
' Destination
Const dfCellAddress As String = "A1" ' needs to be 'A' since entire rows.
Const dMaxRows As Long = 50
Const dNameSuffix As String = "_Part"
' In the loop, this will be replaced by a number ('dwbCount').
Const dIdPlaceHolder As String = "?" ' the '?' is illegal for file names
' The following two lines are dependent on each other.
Const dFileExtension As String = ".txt"
Dim dFileFormat As XlFileFormat: dFileFormat = xlText
' Create a reference to the source first cell ('sfCell').
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
Dim sfCell As Range: Set sfCell = sws.Cells(sfRow, sCol)
' Calculate the number of records (rows) ('drCount').
' This will find the last non-blank cell i.e. cells containing
' formulas evaluating to an empty string are ignored.
' Make sure that the worksheet is not filtered and there are no hidden
' cells.
Dim slCell As Range
Set slCell = sfCell.Resize(sws.Rows.Count - sfRow 1) _
.Find("*", , xlValues, , , xlPrevious)
If slCell Is Nothing Then Exit Sub ' no data
Dim slRow As Long: slRow = slCell.Row
' This is the preferred way, but besides a few pros, it behaves like 'End'
' i.e. it will find the last non-empty cell. A cell is not empty
' if it contains a formula evaluating to an empty string ('""'):
' it is blank.
'Dim slCell As Range
'Set slCell = sfCell.Resize(sws.Rows.Count - sfRow 1) _
.Find("*", , xlFormulas, , , xlPrevious)
'If slCell Is Nothing Then Exit Sub ' no data
'Dim slRow As Long: slRow = slCell.Row
' The classic last row using 'End' will find the last non-empty cell.
'Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
Dim drCount As Long: drCount = slRow - sfRow 1
If drCount < 1 Then Exit Sub ' no data (highly unlikely but...)
' Determine the generic file path (dwbGenericFilePath)
Dim swbBaseName As String: swbBaseName = swb.Name
Dim DotPosition As String: DotPosition = InStrRev(swb.Name, ".")
If DotPosition > 0 Then swbBaseName = Left(swbBaseName, DotPosition - 1)
Dim dwbExtension As String: dwbExtension = dFileExtension
If Left(dwbExtension, 1) <> "." Then dwbExtension = "." & dwbExtension
Dim dwbGenericFilePath As String
dwbGenericFilePath = swb.Path & Application.PathSeparator & swbBaseName _
& dNameSuffix & dIdPlaceHolder & dwbExtension
Application.ScreenUpdating = False
' Additional variables used in the loop.
Dim srg As Range
Dim dwb As Workbook
Dim dws As Worksheet
Dim dfCell As Range
Dim dFilePath As String
Do Until drCount = 0
' Create a reference to the current source range.
If drCount > dMaxRows Then ' all workbooks but the last
Set srg = sfCell.Resize(dMaxRows).EntireRow
Set sfCell = sfCell.Offset(dMaxRows)
drCount = drCount - dMaxRows
Else ' the last workbook
Set srg = sfCell.Resize(drCount).EntireRow
drCount = 0
End If
' Copy the current source range to the current destination range.
dwbCount = dwbCount 1 ' count the number of generated workbooks
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet only
Set dws = dwb.Worksheets(1)
Set dfCell = dws.Range(dfCellAddress)
srg.Copy dfCell
' Save and close the current destination workbook.
dFilePath = Replace(dwbGenericFilePath, dIdPlaceHolder, CStr(dwbCount))
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, dFileFormat
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Loop
ProcExit:
Application.ScreenUpdating = True
Select Case dwbCount
Case 0
MsgBox "No files generated.", vbCritical, ProcName
Case 1
MsgBox "One file generated.", vbInformation, ProcName
Case Else
MsgBox dwbCount & " files generated.", vbInformation, ProcName
End Select
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
uj5u.com熱心網友回復：
@vbasic2008 感謝您的回答。它適用于最后一個檔案，即我們在最后沒有得到多個空行。但是，我們仍然在每個生成的檔案末尾得到一個空行。
轉載請註明出處，本文鏈接：https://www.uj5u.com/ruanti/402978.html
標籤：