VBA Excel 매크로 날짜가 포함 된 셀의 일부로 저장

Question

다음 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 셀에 있습니다. "Doe, John (JDOE)에 대한 XXX 클리닉 프로 수수료 보고서" 이 예제에서는 JDOE_2017-10-20으로 저장하기 위해 새 통합 문서가 필요합니다.

ID를 부여하고 날짜를 기입하는 방법이 있습니까?

Answer 1

는 아래의 코드

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 

Answer 2

대괄호에서 이름 코드를 추출하고 몇 줄의 코드로 날짜를 추가 할 수 있습니다. 당신이 어떤 목적지에 워크 시트를 복사하는 경우 등 몇 가지 다른 수정과 함께

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