[英]VBA Excel Macro save as part of cell with date
I have the following VBA code saving workbook1 sheets to a folder where workbook1 file is saved. 我有以下VBA代码将workbook1工作表保存到保存workbook1文件的文件夹中。 Example: workbook1 has 31 sheets.
示例:workbook1有31张纸。 The code saves each sheet to a new workbook with the same name as the sheet.
该代码将每个工作表保存到与工作表同名的新工作簿中。 (Sheet1, Sheet2, etc).
(Sheet1,Sheet2等)。
Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
I need to modify the code to save the file with the ID and date. 我需要修改代码以使用ID和日期保存文件。 The ID is in cell A1.
该ID在单元格A1中。 "XXX Clinic Pro Fees Report for Doe, John (JDOE)".
“约翰·多伊(XXX)的XXX诊所专业费用报告(JDOE)”。 In this example I need the new workbook to save as JDOE_2017-10-20.
在此示例中,我需要将新工作簿另存为JDOE_2017-10-20。
Is there a way to gave the ID and place the date after it? 有没有办法提供ID并在其后放置日期?
You can extract the name code from within the brackets and append the date with a couple lines of code. 您可以从方括号内提取名称代码,并在日期后加上几行代码。
SheetName = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
SheetName = sn & Format(Date, "_yyyy-mm-dd")
Along with a couple other modifications as, 加上其他一些修改,
Option Explicit
Sub SaveShtsAsBook()
Dim ws As Worksheet, sn As String, mfp As String, n As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error Resume Next '<< a folder exists
mfp = ActiveWorkbook.Path & "\" & Split(ThisWorkbook.Name, Chr(46))(0)
MkDir mfp '<< create a folder
On Error GoTo 0 '<< resume default error handling
With ActiveWorkbook
For n = 1 To .Worksheets.Count
With .Worksheets(n)
sn = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
sn = sn & Format(Date, "_yyyy-mm-dd")
.Copy
With ActiveWorkbook
'save book in this folder
.SaveAs Filename:=mfp & "\" & sn, FileFormat:=xlExcel8
.Close SaveChanges:=False
End With
End With
Next
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Try the below code 试试下面的代码
Sub SaveShtsAsBook()
Dim ldate As String
Dim SheetName1 As String
ldate = Format(Now(), "yyyy-mm-dd")
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
SheetName1 = Range(A1).Value2 & ldate
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
tempstr = Cells(1, 1).Value2
openingParen = InStr(tempstr, "(")
closingParen = InStr(tempstr, ")")
SheetName1 = Mid(tempstr, openingParen + 1, closingParen - openingParen - 1) & "_" & ldate
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName1 & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.