[英]VBA Excel Macro save as part of cell with date
我有以下VBA代碼將workbook1工作表保存到保存workbook1文件的文件夾中。 示例:workbook1有31張紙。 該代碼將每個工作表保存到與工作表同名的新工作簿中。 (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
我需要修改代碼以使用ID和日期保存文件。 該ID在單元格A1中。 “約翰·多伊(XXX)的XXX診所專業費用報告(JDOE)”。 在此示例中,我需要將新工作簿另存為JDOE_2017-10-20。
有沒有辦法提供ID並在其后放置日期?
您可以從方括號內提取名稱代碼,並在日期后加上幾行代碼。
SheetName = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
SheetName = sn & Format(Date, "_yyyy-mm-dd")
加上其他一些修改,
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
試試下面的代碼
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.