我希望将所选内容另存为新工作簿，但如果该工作簿已存在，则希望将其另存为现有工作簿中的新工作表
我希望将所选内容另存为新工作簿，但如果该工作簿已存在，则希望将其另存为现有工作簿中的新工作表
提问于 2019-06-21 00:31:48
对于这一点，我还是个新手。我希望能够做到以下几点：
a copy range
- paste selection in a new workbook
- 将工作簿保存在一个文件夹中，该文件夹的年份值位于H5范围内(如果文件夹不存在，请创建一个)
- 将文件另存为在范围A5、F5、H5中找到的"title_month_year“值(但如果文件已经存在，则另存为新文件
到目前为止，我相信我已经覆盖了1-3个和4个中的一部分。
Option Explicit
Const MYPATH As String = "C:\USERS\3658\Desktop\"
Sub IfNewFolder()
Dim AuditYear As String
AuditYear = Range("H5").Value
'if a particular directory doesnt exists already then create folder.
If Len(Dir(MYPATH & AuditYear, vbDirectory)) = 0 Then
MkDir MYPATH & AuditYear
End If
End Sub
Sub SaveCustomizedCourse()
'copy and past selected data in a new workbook
Range("B8").End(xlDown).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A1").Select
Selection.PasteSpecial xlPasteColumnWidths
Selection.PasteSpecial xlPasteFormats
'save selected data in a new workbook
Dim AuditMonth As String
Dim AuditYear As String
Dim AuditTitle As String
AuditMonth = Range("F5").Value 'MONTH
AuditYear = Range("H5").Value 'YEAR
AuditTitle = Range("A5").Value 'TITLE
IfNewFolder 'creates a yearly subfolder
ActiveWorkbook.SaveAs Filename:= _
MYPATH & AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
MsgBox ("Audit Saved.")
'ActiveWindow.Close
End Sub回答 3
Stack Overflow用户
回答已采纳
发布于 2019-06-21 03:19:13
您可以添加下面的子对象，并在IfNewFolder之后调用它，然后删除它后面的所有代码。
Private Sub Carla(AuditMonth, AuditYear, AuditTitle)
Dim CurWb As Workbook 'This is whatever workbook you are working with
Dim SaveAsWb As Workbook 'This is spare for the workbook in case that has the same name
Dim SaveFileName As String
Set CurWb = ActiveWorkbook
SaveFileName = AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm"
If Len(Dir(MYPATH & SaveFileName)) = 0 Then
CurWb.SaveAs FileName:=MYPATH & SaveFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Else
Set SaveAsWb = Workbooks.Open(MYPATH & SaveFileName)
CurWb.Worksheets("Sheet1").Copy After:=SaveAsWb.Worksheets(Sheets.Count)
SaveAsWb.Save
SaveAsWb.Close
End If
MsgBox ("Audit Saved.")
End SubStack Overflow用户
发布于 2019-06-21 03:23:28
我稍微清理了一下你的代码--见下文。我假设AuditMonth、AuditYear和AuditTitle的值都放在“当前”工作簿中。
Sub SaveCustomizedCourse()
'copy and paste selected data in a new workbook
Dim lngLastRow As Long
Dim wksThis As Excel.Worksheet
Dim wkbNew As Excel.Workbook
'save selected data in a new workbook
Dim AuditMonth As String
Dim AuditYear As String
Dim AuditTitle As String
Set wksThis = ActiveSheet
Set wkbNew = Workbooks.Add
With wksThis
lngLastRow = .Range("B8").End(xlDown).Row
AuditMonth = .Range("F5").Value 'MONTH
AuditYear = .Range("H5").Value 'YEAR
AuditTitle = .Range("A5").Value 'TITLE
.Range("B8:B" & lngLastRow).Copy
End With
With wkbNew.Sheets(1).Range("A1")
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteColumnWidths
End With
IfNewFolder 'creates a yearly subfolder
With wkbNew
.SaveAs Filename:= _
MYPATH & AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
.Close
End With
MsgBox ("Audit Saved.")
End SubStack Overflow用户
发布于 2019-06-23 07:01:38
我发现陈培聪的帖子的这个变体很有帮助。
它完全按照我想要的那样工作，谢谢。
Public Sub IfSheetExists(AuditMonth, AuditYear, AuditTitle)
AuditMonth = Range("F5").Value 'MONTH
AuditYear = Range("H5").Value 'YEAR
AuditTitle = Range("A5").Value 'TITLE
Dim CurWb As Workbook 'This is whatever workbook you are working with
Dim SaveAsWb As Workbook 'This is spare for the workbook in case that has the same name
Dim SaveFileName As String
Set CurWb = ActiveWorkbook
SaveFileName = AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm"
Application.DisplayAlerts = False
If Len(Dir(MYPATH & SaveFileName)) = 0 Then
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
CurWb.SaveAs Filename:=MYPATH & SaveFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
CurWb.Close
Else
Set SaveAsWb = Workbooks.Open(MYPATH & SaveFileName)
CurWb.Worksheets("Sheet1").Copy After:=SaveAsWb.Worksheets(Sheets.Count)
SaveAsWb.save
SaveAsWb.Close
CurWb.Close
End If
Application.DisplayAlerts = True
MsgBox ("Audit Saved.")
Range("A1").Select
End Sub页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/56690379
复制相关文章
相似问题