Excel VBA 打开并另存为

Question

我已经设法根据单元格中的值打开了一系列 Excel 工作簿，但我正在努力将另存为编程。您能帮我在打开每个工作簿后启用另存为吗？

我想要链接到两个单元格的文件名和使用 =LEFT(CELL("filename"),SEARCH("[",CELL("filename"))-1) 从一个单元格派生的文件路径

Sub Open_Workbooks()
Dim SourcePath As String
Dim SourceFile1 As String
Dim SourceFile2 As String

Dim bIsEmpty As Boolean
Dim relativePath As String
Dim sname1 As String
Dim sname2 As String
Dim Ret1
Dim Ret2
Dim PathName1 As String
Dim PathName2 As String
SourcePath = "G:\x\y\"
SourceFile1 = Workbooks("r.xlsm").Sheets("Front sheet").Range("Z1").Text
SourceFile2 = Workbooks("r.xlsm").Sheets("Front sheet").Range("Z2").Text
sname1 = Workbooks("r.xlsm").Sheets("Front sheet").Range("AA1").Text
sname2 = Workbooks("r.xlsm").Sheets("Front sheet").Range("AA2").Text
Ret1 = IsWorkBookOpen("G:\x\y\TEMPLATE.xlsm")
Ret2 = IsWorkBookOpen("G:\x\y\TEMPLATE2.xlsm")
relativePath = Workbooks("r.xlsm").Sheets("Front sheet").Range("H13").Text
PathName1 = Workbooks("r.xlsm").Sheets("Front sheet").Range("H13").Text & Workbooks("r.xlsm").Sheets("Front sheet").Range("AA1").Text & "xlsm"
PathName2 = relativePath & sname2 & "xlsm"


bIsEmpty = False

If IsEmpty(Workbooks("r.xlsm").Sheets("Front sheet").Range("Z1")) = False Then
    'Workboks.Open "G:\x\y\" & Range("[wardchart]").Text & Range("[code]").Text & ".xlsm", ReadOnly:=True
    Workbooks.Open SourcePath & SourceFile1 & ".xlsm", ReadOnly:=False
    ElseIf IsEmpty(Workbooks("Rates, percentages calculator.xlsm").Sheets("Front sheet").Range("Z1")) = True Then
    bIsEmpty = True
End If

 On Error Resume Next

    If Ret1 = True Then
    'ThisWorkbook.SaveAs PathName1, xlOpenXMLMacroEnabled, CreateBackup:=False
    ThisWorkbook.SaveCopyAs PathName1
    ElseIf Ret1 = False Then
    bIsEmpty = True
    End If

On Error Resume Next

End Sub

Answer 1

我通过将文件复制到路径然后随后打开解决了这个问题：

Sub CopyRenameFile()
Dim src As String, dst As String, f1 As String, f2 As String
Dim rf1 As String, rf2 As String

'source directory
src = Workbooks("r.xlsm").Sheets("Front sheet").Range("AC1").Text

'destination directory
dst = Workbooks("r.xlsm").Sheets("Front sheet").Range("AB1").Text

'file name
f1 = Workbooks("r.xlsm").Sheets("Front sheet").Range("Z1").Text

'file name
f2 = Workbooks("r.xlsm").Sheets("Front sheet").Range("Z2").Text

'rename file
rf1 = Workbooks("r.xlsm").Sheets("Front sheet").Range("AA1").Text

'rename file
 rf2 = Workbooks("r.xlsm").Sheets("Front sheet").Range("AA2").Text

 On Error Resume Next
 If IsEmpty(Workbooks("r.xlsm").Sheets("Front sheet").Range("Z1")) = False Then
   FileCopy src & f1 & ".xlsm", dst & rf1 & ".xlsm"
   End If
 On Error GoTo 0

 On Error Resume Next
 If IsEmpty(Workbooks("r.xlsm").Sheets("Front sheet").Range("Z2")) = False Then
    FileCopy src & f2 & ".xlsm", dst & rf2 & ".xlsm"
    End If
 On Error GoTo 0

End Sub

Answer 2

我不完全确定是否可以帮助您解决这个问题，但也许这可能会帮助您找到正确的方向：

Sub Copy_ActiveSheet_1()
'Working in Excel 97-2017
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String

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

Set Sourcewb = ActiveWorkbook

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

'Determine the Excel version and file extension/format
With Destwb
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
End With

'    'Change all cells in the worksheet to values if you want
'    With Destwb.Sheets(1).UsedRange
'        .Cells.Copy
'        .Cells.PasteSpecial xlPasteValues
'        .Cells(1).Select
'    End With
'    Application.CutCopyMode = False

'Save the new workbook and close it
TempFilePath = Application.DefaultFilePath & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")

With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    .Close SaveChanges:=False
End With

MsgBox "You can find the new file in " & TempFilePath

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



Sub Copy_ActiveSheet_2()
'Working in Excel 2000-2016
Dim fname As Variant
Dim NewWb As Workbook
Dim FileFormatValue As Long

'Check the Excel version
If Val(Application.Version) < 9 Then Exit Sub
If Val(Application.Version) < 12 Then

    'Only choice in the "Save as type" dropdown is Excel files(xls)
    'because the Excel version is 2000-2003
    fname = Application.GetSaveAsFilename(InitialFileName:="", _
    filefilter:="Excel Files (*.xls), *.xls", _
    Title:="This example copies the ActiveSheet to a new workbook")

    If fname <> False Then
        'Copy the ActiveSheet to new workbook
        ActiveSheet.Copy
        Set NewWb = ActiveWorkbook

        'We use the 2000-2003 format xlWorkbookNormal here to save as xls
        NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
        NewWb.Close False
        Set NewWb = Nothing

    End If
Else
    'Give the user the choice to save in 2000-2003 format or in one of the
    'new formats. Use the "Save as type" dropdown to make a choice,Default =
    'Excel Macro Enabled Workbook. You can add or remove formats to/from the list

    fname = Application.GetSaveAsFilename(InitialFileName:="", filefilter:= _
        " Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
        " Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
        " Excel 2000-2003 Workbook (*.xls), *.xls," & _
        " Excel Binary Workbook (*.xlsb), *.xlsb", _
        FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")

    'Find the correct FileFormat that match the choice in the "Save as type" list
    If fname <> False Then
        Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
        Case "xls": FileFormatValue = 56
        Case "xlsx": FileFormatValue = 51
        Case "xlsm": FileFormatValue = 52
        Case "xlsb": FileFormatValue = 50
        Case Else: FileFormatValue = 0
        End Select

        'Now we can create/Save the file with the xlFileFormat parameter
        'value that match the file extension
        If FileFormatValue = 0 Then
            MsgBox "Sorry, unknown file extension"
        Else
            'Copies the ActiveSheet to new workbook
            ActiveSheet.Copy
            Set NewWb = ActiveWorkbook

            'Save the file in the format you choose in the "Save as type" dropdown
            NewWb.SaveAs fname, FileFormat:= _
                         FileFormatValue, CreateBackup:=False
            NewWb.Close False
            Set NewWb = Nothing

        End If
    End If
End If
End Sub