Мне нужно сохранить файл в папку - этот файл не может перезаписать существующий файл - PullRequest
Новая
       18

Мне нужно сохранить файл в папку - этот файл не может перезаписать существующий файл

0 голосов
/ 23 мая 2019

У меня есть пара макросов, которые, я ЗНАЮ, перезапишут существующий файл - мне нужно переписать этот макрос, чтобы он не перезаписывал файл. Я пробовал разные решения, но я не могу заставить их работать в моей среде.

Вот макрос, который я написал до сих пор: 

Sub email_workbook()     

Dim wb1 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Set wb1 = ActiveWorkbook

TempFilePath = Environ$("temp") & "\"
TempFileName = Range("H22") & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))

wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
    .to = "person1@PLACE.COM"
    .CC = "MPERSON@PLACE.COM" & " " & "LPERSON@PLACE.COM"
    .BCC = ""
    .Subject = "SUBJECT" & Range("H22")
    .Body = "Please review ETC.ETC."
    .Attachments.Add TempFilePath & TempFileName & FileExtStr
    .Display

    End With

On Error GoTo 0


   Dim myFile As String

   myFile = ActiveWorkbook.Name

   Application.DisplayAlerts = False ' Disregard overwriting message.
   ActiveWorkbook.SaveAs Filename:="U:\Public\WAKKA\WAKKAWAKKA - To Review"


Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With


Call SaveFileExcel


End Sub

Sub SaveFileExcel () Тусклый путь As String Dim filename1 As String path = "U: \ Public \ WAKKA - WAKKAWAKKA" filename1 = Range ("W1"). Текст Application.DisplayAlerts = True 'If Dir ("f: ull \ path \ with \ filename.xls") <> "" Тогда 'Kill "f: ull \ path \ with \ filename.xls"' End If ActiveWorkbook.SaveAs

Имя файла: = путь и имя файла1 & ".xlsm", FileFormat: = xlOpenXMLWorkbookMacroEnabled Application.DisplayAlerts = True End Sub

1 Ответ

1 голос
/ 23 мая 2019

Вам нужно решить, каким будет новое имя, если файл уже существует ... добавление временной метки к имени файла обычно помогает сохранить его уникальным.

Просто повторно используйте ваш код: 

Sub SaveFileExcel()
Dim path As String
Dim filename1 As String
path = "U:\Public\WAKKA - WAKKAWAKKA"
filename1 = Range("W1").Text
Application.DisplayAlerts = True

If Not Dir(path & filename1 & ".xlsm") <> "" Then
    filename1 = filename1 & "file_already_exists_with_same_name"
End If

ActiveWorkbook.SaveAs Filename:=path & filename1 & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled

Application.DisplayAlerts = True
End Sub
...