使用清除功能从 Excel VBA 生成 CSV

Question

我在 Excel 中有一个 VBA 脚本，用于从 Table1 第 1 列中提取值列表（实际上只是实验室编号的列表，可以是任意行数，通常不超过 30 行）并将其放入 CSV 文件中NiceLabel 将在共享驱动器中拾取并处理它。 然后，数据将从原始 CSV 中清除，以便下一个人可以使用它。 （目前删除第2-30行）

然而，一些用户仍然设法破解代码并最终打印 33MB 的 csv 文件（他们以某种方式设法生成所有 100 万行，然后脚本尝试将它们附加到 csv.txt 文件）。 有没有一种更简单的方法可以消除用户错误（以及随后打印机堵塞）的风险

Sub printlist()
'
' printlist Macro
'

Dim wbkExport As Workbook
Dim shtToExport As Worksheet

Set shtToExport = ThisWorkbook.Worksheets("List")
Set wbkExport = Application.Workbooks.Add
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False
wbkExport.SaveAs Filename:="\\SVWDLIMSPRINT1\OnDemand\" & Format(Date, "yyyymmdd") & Format(Time, "hhmmss") & ".csv", FileFormat:=xlCSV
Application.DisplayAlerts = True
wbkExport.Close SaveChanges:=False

    Rows("2:30").Select
Selection.Delete
    Range("Table1[[Lab Number]:[Lab Number]]").Select
    Selection.ClearContents


'
End Sub

上面的方法在 99.9% 的情况下都有效，但 0.1% 生成过大的文件会导致严重的中断。 或者，NiceLabel 中有一种使用 VBScript 拒绝较大文件的方法。

Answer 1

从 Excel 表复制值

• 如果您使用表格范围，则无需关心用户在其之外执行的操作。
• 如果一个顽固的用户向表中添加了一百万行，你的麻烦仍然存在。

Sub ExportList()
    
    ' Reference the source range.
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = swb.Sheets("List")
    Dim slo As ListObject: Set slo = sws.ListObjects("Table1")
    ' Not sure what you want to do with the column.
    'Dim slc As ListColumn: Set slc = slo.ListColumns("Lab Number")
    
    ' Check if the table is empty.
    If slo.DataBodyRange Is Nothing Then
        MsgBox "The table is empty.", vbCritical
        Exit Sub
    End If
    
    Dim srg As Range: Set srg = slo.Range ' maybe 'slc.Range'?
    ' If you don't want to copy the headers,
    ' replace `.Range` with `.DataBodyRange`.
    
    ' Reference the destination range (same size as the source range).
    
    Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet)
    Dim dws As Worksheet: Set dws = dwb.Sheets(1)
    Dim drg As Range:
    Set drg = dws.Range("A1").Resize(srg.Rows.Count, srg.Columns.Count)
    
    Application.ScreenUpdating = False 

    ' Copy values from source to destination.
    
    drg.Value = srg.Value

    ' Save and close the destination workbook.
    
    Application.DisplayAlerts = False
        dwb.SaveAs Filename:="\\SVWDLIMSPRINT1\OnDemand\" _
            & Format(Now, "yyyymmddhhmmss") & ".csv", _
            FileFormat:=xlCSV
    Application.DisplayAlerts = True
    dwb.Close SaveChanges:=False ' it just got saved

    ' Empty the (source) table.

    With slo
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
        .DataBodyRange.Delete Shift:=xlShiftUp
    End With
    
    ' Save the (modified) source workbook.
    
    'swb.Save SaveChanges:=True
    
    ' Inform.
    
    Application.ScreenUpdating = True

    MsgBox "List exported.", vbInformation
    
End Sub