Question

加载一个XLS文件对于我们放在一起的快速应用程序来说有点痛苦（我们知道如何做到这一点，但它不值得花时间，特别是在C ++中）所以我们将采取简单的方法让用户导出CSV副本。但是为了省去他们的麻烦我想知道我们是否可以拥有一个宏，它会在Excel 2007中保存XLS（X）时自动保存CSV版本？

更新在Timores的回答之后，我挖了一下并想出了这个：

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFileName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook
    TempFileName = Sourcewb.FullName + ".csv"

    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    'Save the new workbook and close it
    With Destwb
        .SaveAs Filename:=TempFileName, FileFormat:=xlCSV, ConflictResolution:=xlLocalSessionChanges
        .Close SaveChanges:=False
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

除非我无法强制保存CSV，而不是在询问我是否要覆盖，即使在添加ConflictResolution:=xlLocalSessionChanges

Answer 1

原始版本：

在Excel的VB编辑器部分，在左侧导航菜单中选择“ThisWorkbok”。在右侧的编辑器中，选择左侧下拉列表中的“工作簿”和右侧的“前任”。

将宏替换为：

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    ActiveWorkbook.SaveCopyAs ActiveWorkbook.FullName + ".csv"
End Sub

这将使用CSV扩展名制作副本。

请注意，XLSX文件不能有宏（您需要XLSM扩展，或者旧的XLS扩展），并且用户需要具有中等或低级别的安全性才能运行宏（或者您必须签署文件。）

已修改版本：

在看到下面的评论后，我再次测试了它。奇怪的是，它没有像第一次那样工作。这是一个固定版本。同样，在宏编辑器的“本工作簿”部分：

Dim fInSaving As Boolean

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

If fInSaving Then
    Exit Sub
End If

fInSaving = True

Dim workbookName As String
Dim parentPath As String
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

If SaveAsUI Then

    Dim result
    result = Application.GetSaveAsFilename

    If VarType(result) = vbBoolean Then
        If CBool(result) = False Then
            Exit Sub ' user cancelled the dialog box
        End If
    End If

    workbookName = fs.GetFileName(result)
    parentPath = fs.GetParentFolderName(result)
Else

    workbookName = ActiveWorkbook.name
    parentPath = ActiveWorkbook.path
End If


Dim index As Integer
index = InStr(workbookName, ".")

Dim name As String
name = Left(workbookName, index - 1)

' extension can be empty is user enters simply a name in the 'File / Save as' dialog
' so it is not computed (but hard-coded below)

' do not ask for confirmation to overwrite an existing file
Application.DisplayAlerts = False

' save a copy
ActiveWorkbook.SaveAs fs.BuildPath(parentPath, name & ".csv"), XlFileFormat.xlCSV

' Save the normal workbook in the original name
ActiveWorkbook.SaveAs fs.BuildPath(parentPath, name & ".xlsm"), XlFileFormat.xlOpenXMLWorkbookMacroEnabled
Cancel = True

Application.DisplayAlerts = True
fInSaving = False
End Sub

Private Sub Workbook_Open()

    fInSaving = False
End Sub

令人惊讶的是，调用ActiveWorkbook.SaveAs再次触发宏=＆gt;用于防止无限递归的全局布尔值。

Answer 2

避免XL询问是否要覆盖使用Application.DisplayAlerts = False（然后在保存后重置为True）

Answer 3

由于OP关于保存对话框的问题似乎仍然是开放的，即使查尔斯有关于“真的存储的答案吗？是吗？你确定吗？但该文件存在？无论如何？绝对肯定？”警告，我以为我会分享完整的脚本，警告信息被禁用为完整起见：

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFileName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    Set Sourcewb = ActiveWorkbook
    TempFileName = Sourcewb.FullName + ".csv"

    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    'Save the new workbook and close it
    With Destwb
        .SaveAs Filename:=TempFileName, FileFormat:=xlCSV, ConflictResolution:=xlLocalSessionChanges
        .Close SaveChanges:=False
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub

您是否可以使用Excel宏将副本自动保存为CSV

3 个答案: