我已经设法根据单元格中的值打开了一系列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
答案 0 :(得分：0)
我通过文件复制到路径然后随后打开来解决这个问题：
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
答案 1 :(得分：-1)
我不完全确定我是否可以帮助您解决这个问题，但也许这可能有助于您朝着正确的方向前进：
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