Question

首先-在此先感谢所有允许这样做的人！如果代码冗长又草率，请提前对不起...我对VBA不太熟悉，似乎不知所措地用锤子敲打它使其提交提交大声笑

我已经为此苦苦挣扎了大约八天，试图在寻求帮助之前坚持不懈。这是我想做的。

在用Excel完成报表后，我想将“另存为新工作表”另存到新工作簿中，并将其保存到与创建的PDF相同的位置（子文件夹），以便我可以将Excel文件通过电子邮件发送给客户端，他们可以进行编辑和返回，因此不必转换客户数据，并且表单本质上就像PDF。另外，输出文件名必须与现有的输出PDF文件相同（单元格数据将提供此文件名），以便文件不会由于重命名问题而丢失，并且与传输文件匹配。

查看我现在拥有的代码，该代码可以很好地用于创建子文件夹，并使用生成的PDF整理其中的所有内容，但是我也无法获得仅是文本的Excel文件（我发现这种方法很有效，复制宏按钮，链接到原始文件的公式等）。我一定要格式化，而不是单元格公式……只是单元格文本。

这有可能吗？

Sub SCL_SaveAndFile()

    Dim myDir As String, mySht As String, mySubDir As String, mySubSub As String, mySubName As String, mySubName1 As String

    'Example of current Folder Structure
    'C:\RFP Documents\[RFP NUMBER]\[CLIENT NAME]\[DOCUMENT TITLE]\Document.pdf

    'Would also like this, of just the active sheet, with just text no formulas copied
    'C:\RFP Documents\[RFP NUMBER]\[CLIENT NAME]\[DOCUMENT TITLE]\Document.xslx

    myDir = "C:\RFP Documents\" 'root destination
    mySubDir = ActiveSheet.Range("R3").Value 'rfp number
    mySubSub = ActiveSheet.Range("R2").Value 'client name
    mySubName = ActiveSheet.Range("A1").Value 'document title
    mySubName1 = "RFP PACKAGE" 'sub folder where documents are stored to be emailed to client
    mySht = ActiveSheet.Range("R1").Value 'document no or filename

    On Error Resume Next
    MkDir myDir
    MkDir myDir & "\" & mySubDir
    MkDir myDir & "\" & mySubDir & "\" & mySubSub & "\" & mySubName1
    MkDir myDir & "\" & mySubDir & "\" & mySubSub & "\" & mySubName1 & "\" & mySubName
    On Error GoTo 0

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        filename:=myDir & "\" & mySubDir & "\" & mySubSub & "\" & "\" & mySubName1 & "\" & mySubName & "\" & mySht, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

End Sub

感谢大家的帮助！

Answer 1

在您的代码下方添加此代码：

复制Activesheet
将所有格式和值都粘贴为特殊格式
将新创建的工作簿保存在同一目标位置

Dim nwb As Workbook, wb As Workbook, wks As Worksheet
Set wb = ActiveWorkbook
Set wks = ActiveSheet
wks.Copy
Set nwb = ActiveWorkbook
With nwb.Worksheets(1)
.UsedRange.Copy
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
End With

nwb.SaveAs fileName:=myDir & "\" & mySubDir & "\" & mySubSub & "\" & "\" & mySubName1 & "\" & mySubName & "\" & mySht & ".xlsx"
nwb.Close

完整代码

Sub SCL_SaveAndFile()

    Dim myDir As String, mySht As String, mySubDir As String, mySubSub As String, mySubName As String, mySubName1 As String
    Dim nwb As Workbook, wb As Workbook, wks As Worksheet
    Set wb = ActiveWorkbook
    Set wks = ActiveSheet

    myDir = "C:\RFP Documents\" 'root destination
    mySubDir = ActiveSheet.Range("R3").Value 'rfp number
    mySubSub = ActiveSheet.Range("R2").Value 'client name
    mySubName = ActiveSheet.Range("A1").Value 'document title
    mySubName1 = "RFP PACKAGE" 'sub folder where documents are stored to be emailed to client
    mySht = ActiveSheet.Range("R1").Value 'document no or filename

    On Error Resume Next
    MkDir myDir
    MkDir myDir & "\" & mySubDir
    MkDir myDir & "\" & mySubDir & "\" & mySubSub & "\" & mySubName1
    MkDir myDir & "\" & mySubDir & "\" & mySubSub & "\" & mySubName1 & "\" & mySubName
    On Error GoTo 0

    wks.ExportAsFixedFormat Type:=xlTypePDF, _
        fileName:=myDir & "\" & mySubDir & "\" & mySubSub & "\" & "\" & mySubName1 & "\" & mySubName & "\" & mySht, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

    wks.Copy

    Set nwb = ActiveWorkbook
    With nwb.Worksheets(1)
    .UsedRange.Copy
    .Range("A1").PasteSpecial xlPasteValues
    .Range("A1").PasteSpecial xlPasteFormats
    End With

    nwb.SaveAs fileName:=myDir & "\" & mySubDir & "\" & mySubSub & "\" & "\" & mySubName1 & "\" & mySubName & "\" & mySht & ".xlsx"
    nwb.Close

End Sub

如何将工作表另存为特定文件夹中的新工作簿

1 个答案: