使用 VBA 将 Excel 数据保存为 csv - 删除文件末尾的空白行以保存

我正在 VBA 中创建一组 csv 文件。

我的脚本正在创建我需要的数据集，但行数在循环的多次迭代中有所不同。例如，对于 i=2，我有 100,000 行，但对于 i=3，我有 22,000 行。问题是，当 Excel 保存这些单独的 csv 文件时，它不会截断末尾的空格。这会在文件末尾留下 78,000 个空白行，这是一个问题，因为我需要生成大约 2,000 个文件，每个文件都有几兆字节大。 （我在 SQL 中有一些需要的数据，但无法在 SQL 本身中进行数学计算。说来话长。）

此问题通常在手动保存时发生 - 您需要在删除行后关闭文件，然后重新打开，在这种情况下这不是一个选项，因为它在 VBA 中自动发生。使用另一种语言的脚本保存后删除空白行并不是真正的选择，因为我实际上需要输出文件以适合可用的驱动器，而且它们现在不必要地巨大。

我努力了Sheets(1).Range("A2:F1000001").ClearContents，但这不会截断任何内容。在保存之前删除行应该不会产生类似的影响，因为 Excel 会保存所有行直到文件末尾，因为它存储的是所操作的最右下角的单元格。有没有办法让Excel只保存我需要的行？

这是我用来保存的代码：（截断发生在更早的时候，在调用这个的路由中）

Sub SaveCSV()
'Save the file as a CSV...
  Dim OutputFile As Variant
  Dim FilePath As Variant

  OutputPath = ActiveWorkbook.Worksheets("Macro").Range("B2").Value
  OutputFile = OutputPath & ActiveWorkbook.Worksheets("Macro").Range("B1").Value
  Application.DisplayAlerts = False 'DISABLE ALERT on Save - overwrite, etc.
  ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
  Application.DisplayAlerts = True 'DISPLAY ALERTS
End Sub

相关代码在这里：

'While looping through Al, inside of looping through A and B...
'Created output values needed in this case, in an array...

Sheets(1).Range("A2:E90001") = Output

ActiveWorkbook.Worksheets(1).Range("F2").Formula = "=(does not matter, some formula)"
ActiveWorkbook.Worksheets(1).Range("F2").AutoFill Destination:=Range("F2:F90001")

'Set Filename to save into...
ActiveWorkbook.Worksheets("Macro").Range("B1").Value = "Values_AP" & Format(A, "#") & "_BP" & Format(B, "#") & "_Al" & Format(Al, "#")

'Save Sheet and reset...
Call SaveCSV
Sheets(1).Range("A2:F90001").ClearContents
CurrRow = 1

Next Al

您可以获得UsedRange重新计算自身而不用简单的删除列和行

ActiveSheet.UsedRange

或者，您可以通过使用以下代码删除最后使用的单元格下方的区域来自动手动删除“错误”使用范围DRJ 的 VBAexpress 文章，或者通过使用插件，例如尽快公用事业

DRJ 文章中的函数是：

Option Explicit 

Sub ExcelDiet() 

Dim j               As Long 
Dim k               As Long 
Dim LastRow         As Long 
Dim LastCol         As Long 
Dim ColFormula      As Range 
Dim RowFormula      As Range 
Dim ColValue        As Range 
Dim RowValue        As Range 
Dim Shp             As Shape 
Dim ws              As Worksheet 

Application.ScreenUpdating = False 
Application.DisplayAlerts = False 

On Error Resume Next 

For Each ws In Worksheets 
    With ws 
         'Find the last used cell with a formula and value
         'Search by Columns and Rows
        On Error Resume Next 
        Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _ 
        LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) 
        Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _ 
        LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) 
        Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _ 
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious) 
        Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _ 
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious) 
        On Error GoTo 0 

         'Determine the last column
        If ColFormula Is Nothing Then 
            LastCol = 0 
        Else 
            LastCol = ColFormula.Column 
        End If 
        If Not ColValue Is Nothing Then 
            LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column) 
        End If 

         'Determine the last row
        If RowFormula Is Nothing Then 
            LastRow = 0 
        Else 
            LastRow = RowFormula.Row 
        End If 
        If Not RowValue Is Nothing Then 
            LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row) 
        End If 

         'Determine if any shapes are beyond the last row and last column
        For Each Shp In .Shapes 
            j = 0 
            k = 0 
            On Error Resume Next 
            j = Shp.TopLeftCell.Row 
            k = Shp.TopLeftCell.Column 
            On Error GoTo 0 
            If j > 0 And k > 0 Then 
                Do Until .Cells(j, k).Top > Shp.Top + Shp.Height 
                    j = j + 1 
                Loop 
                If j > LastRow Then 
                    LastRow = j 
                End If 
                Do Until .Cells(j, k).Left > Shp.Left + Shp.Width 
                    k = k + 1 
                Loop 
                If k > LastCol Then 
                    LastCol = k 
                End If 
            End If 
        Next 

        .Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete 
        .Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete 
    End With 
Next 

Application.ScreenUpdating = True 
Application.DisplayAlerts = True 

End Sub