Добрый день, подскажите пожалуйста, что нужно добавить в мой код что бы сформированный документ ворд, сохранялся в новую созданную папку, папка имела имя с данными ячейками фио = Cells(61, 3), а документ ворд с именем шаблона
[vba]
Код
Option Explicit
Const WD_TEMPL = "РЕШЕНИЕ.dotx"
Sub Решение_неверный_грз() 'Const B2 = vbLf & vbLf & "Продолжить?"
Static wdApp As Object Dim newFileName As String Dim newFilePath As String Dim wdDoc As Object Dim x, кто_расматривает, номер_постановления, дата_вынесения, лицо_вынесшее_постановление, дата_жалобы, номер_жалобы, фио_рп, номер_постановления_2, дата_вынесения_2, лицо_вынесшее_постановление_2, фио_дп, дата_расмотр, дата_расмотр_2, фио, дата_наруш, время_наруш, место, кам, номер_кам, грз, марка, скорость_тс, перевышение, разрешенная, фио_2, фио_3, номер_постановления_3, дата_вынесения_3, лицо_вынесшее_постановление_3, фио_дп_2, часть, статья, сумма, начальник Set x = ActiveSheet Sheets("Ошибка грз").Select
x.Select On Error Resume Next x = wdApp.Name If Err Then Err.Clear Set wdApp = GetObject(, "word.application") If Err Then Err.Clear Set wdApp = CreateObject("word.application") If Err Then MsgBox "Невозможно открыть Word", vbCritical Exit Sub End If End If End If With wdApp .Visible = True x = .Documents.Count Set wdDoc = .Documents.Add(ThisWorkbook.Path & "\Шаблоны\неверный_грз\" & WD_TEMPL) If .Documents.Count <= x Then MsgBox "Не найден шаблон " & WD_TEMPL, vbCritical Exit Sub End If End With With wdDoc .Bookmarks("кто_расматривает").Range.Text = кто_расматривает .Bookmarks("номер_постановления").Range.Text = номер_постановления .Bookmarks("дата_вынесения").Range.Text = дата_вынесения .Bookmarks("лицо_вынесшее_постановление").Range.Text = лицо_вынесшее_постановление .Bookmarks("дата_жалобы").Range.Text = дата_жалобы .Bookmarks("номер_жалобы").Range.Text = номер_жалобы .Bookmarks("фио_рп").Range.Text = фио_рп .Bookmarks("номер_постановления_2").Range.Text = номер_постановления .Bookmarks("дата_вынесения_2").Range.Text = дата_вынесения_2 .Bookmarks("лицо_вынесшее_постановление_2").Range.Text = лицо_вынесшее_постановление_2 .Bookmarks("фио_дп").Range.Text = фио_дп .Bookmarks("дата_расмотр").Range.Text = дата_расмотр .Bookmarks("дата_расмотр_2").Range.Text = дата_расмотр_2 .Bookmarks("фио").Range.Text = фио
End With wdApp.Activate
End Sub
[/vba]
Добрый день, подскажите пожалуйста, что нужно добавить в мой код что бы сформированный документ ворд, сохранялся в новую созданную папку, папка имела имя с данными ячейками фио = Cells(61, 3), а документ ворд с именем шаблона
[vba]
Код
Option Explicit
Const WD_TEMPL = "РЕШЕНИЕ.dotx"
Sub Решение_неверный_грз() 'Const B2 = vbLf & vbLf & "Продолжить?"
Static wdApp As Object Dim newFileName As String Dim newFilePath As String Dim wdDoc As Object Dim x, кто_расматривает, номер_постановления, дата_вынесения, лицо_вынесшее_постановление, дата_жалобы, номер_жалобы, фио_рп, номер_постановления_2, дата_вынесения_2, лицо_вынесшее_постановление_2, фио_дп, дата_расмотр, дата_расмотр_2, фио, дата_наруш, время_наруш, место, кам, номер_кам, грз, марка, скорость_тс, перевышение, разрешенная, фио_2, фио_3, номер_постановления_3, дата_вынесения_3, лицо_вынесшее_постановление_3, фио_дп_2, часть, статья, сумма, начальник Set x = ActiveSheet Sheets("Ошибка грз").Select
x.Select On Error Resume Next x = wdApp.Name If Err Then Err.Clear Set wdApp = GetObject(, "word.application") If Err Then Err.Clear Set wdApp = CreateObject("word.application") If Err Then MsgBox "Невозможно открыть Word", vbCritical Exit Sub End If End If End If With wdApp .Visible = True x = .Documents.Count Set wdDoc = .Documents.Add(ThisWorkbook.Path & "\Шаблоны\неверный_грз\" & WD_TEMPL) If .Documents.Count <= x Then MsgBox "Не найден шаблон " & WD_TEMPL, vbCritical Exit Sub End If End With With wdDoc .Bookmarks("кто_расматривает").Range.Text = кто_расматривает .Bookmarks("номер_постановления").Range.Text = номер_постановления .Bookmarks("дата_вынесения").Range.Text = дата_вынесения .Bookmarks("лицо_вынесшее_постановление").Range.Text = лицо_вынесшее_постановление .Bookmarks("дата_жалобы").Range.Text = дата_жалобы .Bookmarks("номер_жалобы").Range.Text = номер_жалобы .Bookmarks("фио_рп").Range.Text = фио_рп .Bookmarks("номер_постановления_2").Range.Text = номер_постановления .Bookmarks("дата_вынесения_2").Range.Text = дата_вынесения_2 .Bookmarks("лицо_вынесшее_постановление_2").Range.Text = лицо_вынесшее_постановление_2 .Bookmarks("фио_дп").Range.Text = фио_дп .Bookmarks("дата_расмотр").Range.Text = дата_расмотр .Bookmarks("дата_расмотр_2").Range.Text = дата_расмотр_2 .Bookmarks("фио").Range.Text = фио
Привет! Не знаю, смогу ли помочь. Раз уж ответов пока нет, то глянь этот кусок кода. Может, найдешь искомое, пока не подтянулись более опытные форумчане.
Function NewFolderName() As String NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ФИО) MkDir NewFolderName End Function
Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function Function Get_Now() As String: Get_Now = Get_Date & " â " & Get_Time: End Function
[/vba]
Привет! Не знаю, смогу ли помочь. Раз уж ответов пока нет, то глянь этот кусок кода. Может, найдешь искомое, пока не подтянулись более опытные форумчане.
Function NewFolderName() As String NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ФИО) MkDir NewFolderName End Function
Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function Function Get_Now() As String: Get_Now = Get_Date & " â " & Get_Time: End Function