將作業表復制到以單元格資料為標題的新作業簿

我已經使用了以下內容并希望將其修改為不覆寫檔案但創建一個新檔案我該怎么做或者我可以修改新檔案字串以在檔案名中包含一個單元格值 每日報告單元格值是 =昨天，格式為 2022 年 3 月 3 日，所以最后我希望每個新檔案都是昨天的日期 每日報告

Option Explicit

Public Sub TestMe()

    Dim newWb As Workbook
    Dim newWbPath As String: newWbPath = ThisWorkbook.Path & "\Daily Report.xlsx"
    Set newWb = Workbooks.Add

    ThisWorkbook.Worksheets("Daily Reports").Cells.Copy
    newWb.Worksheets(1).Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

    newWb.SaveAs newWbPath
    newWb.Close

End Sub

uj5u.com熱心網友回復：

將作業表匯出到新作業簿

僅復制值

Sub ExportDailyReport()
    
    ' Source
    Const sName As String = "Daily Reports"
    ' Destination
    Const dName As String = "" ' if you don't want it to be e.g. 'Sheet1'
    ' I prefer " yyyymmdd hhmmss" (stays sorted in WinExp) and after the name.
    Const dDatePattern As String = "m-d-yyyy"
    Const dDateNameSeparator As String = " "
    Const dNameRight As String = "Daily Report.xlsx"
    ' Both
    Const DateCellAddress As String = "A1"
    
    ' Source
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
    
    ' Reference the source range.
    Dim srg As Range: Set srg = sws.UsedRange
    
    ' Destination
    
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet) ' single ws
    Dim dws As Worksheet: Set dws = dwb.Worksheets(1)
    If Len(dName) > 0 Then dws.Name = dName ' rename worksheet, or not
    
    ' Reference the destination range.
    Dim drg As Range: Set drg = dws.Range(srg.Cells(1).Address) _
        .Resize(srg.Rows.Count, srg.Columns.Count)
    
    ' Copy values by assignment (most efficient).
    drg.Value = srg.Value
    
    ' Build the destination file path.
    Dim dFilePath As String: dFilePath = swb.Path & "\" _
        & Format(dws.Range(DateCellAddress).Value, dDatePattern) _
        & dDateNameSeparator & dNameRight
    
    ' Save and close.
    Application.DisplayAlerts = False ' overwrite without confirmation
    dwb.SaveAs dFilePath
    Application.DisplayAlerts = True
    dwb.Close SaveChanges:=False
    
    ' Inform.
    Application.ScreenUpdating = True
    MsgBox "Daily report exported.", vbInformation

End Sub

按原樣復制

Sub ExportDailyReportAsIs()
    
    ' Source
    Const sName As String = "Daily Reports"
    ' Destination
    Const dName As String = "" ' if you don't want it to be 'Daily Reports'
    ' I prefer " yyyymmdd hhmmss" (stays sorted in WinExp) and after the name.
    Const dDatePattern As String = "m-d-yyyy"
    Const dDateNameSeparator As String = " "
    Const dNameRight As String = "Daily Report.xlsx"
    ' Both
    Const DateCellAddress As String = "A1"
    
    ' Source
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
    
    Application.ScreenUpdating = False
    
    ' Return the copy of the worksheet in a new workbook.
    sws.Copy
    
    ' Destination
    
    Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
    Dim dws As Worksheet: Set dws = dwb.Worksheets(1)
    If Len(dName) > 0 Then dws.Name = dName ' rename worksheet, or not
    ' To remove the formulas you can do:
    'dws.UsedRange.Value = dws.UsedRange.Value
    
    ' Build the destination file path.
    Dim dFilePath As String: dFilePath = swb.Path & "\" _
        & Format(dws.Range(DateCellAddress).Value, dDatePattern) _
        & dDateNameSeparator & dNameRight
    
    ' Save and close.
    Application.DisplayAlerts = False ' overwrite without confirmation
    dwb.SaveAs dFilePath
    Application.DisplayAlerts = True
    dwb.Close SaveChanges:=False
    
    ' Inform.
    Application.ScreenUpdating = True
    MsgBox "Daily report exported.", vbInformation

End Sub

標籤：擅长 vba

上一篇：使用vlookup的BinRanges沒有給出正確的結果

下一篇：VBA查找具有多個單詞的單元格并將一個單詞的字體顏色更改為紅色