Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
из Excel в word, сохранение файла шаблона и готового фала в разные папки
 
#1
19.04.2021 19:15:50
Код
Sub AKT()
    Dim wdApp As Object
    Dim wdDoc As Object
   
HomeDir$ = ThisWorkbook.Path
Set wdApp = CreateObject("Word.Application")
    i% = 3
Do
    If Cells(i%, 1).Value = "" Then Exit Do
    If Cells(i%, 1).Value <> "" Then
      
Название$ = Cells(i%, 1).Value
Производитель$ = Cells(i%, 2).Value
Центр$ = Cells(i%, 3).Value
AG$ = Cells(i%, 4).Value
AT$ = Cells(i%, 5).Value
  
DataC$ = Date
  
FileCopy HomeDir$ + "\AKT.doc", HomeDir$ & "\" & "Готовые документы" + "\Акт " + Название$ + "_" + Производитель$ + "_" + DataC$ + ".doc"
Set wdDoc = wdApp.Documents.Open(HomeDir$ & "\" & "Готовые документы" + "\Акт " + Название$ + "_" + Производитель$ + "_" + DataC$ + ".doc")
  
  
wdDoc.Range.Find.Execute FindText:="&date", Replacewith:=DataC$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&ID", Replacewith:=Название$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&OOO", Replacewith:=Производитель$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&Centr", Replacewith:=Центр$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&AG", Replacewith:=AG$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&AT", Replacewith:=AT$, Replace:=2
wdDoc.Range.Find.Execute Replace:=wdReplaceALL
  
  
wdDoc.Save
wdDoc.Close
End If
i% = i% + 1
Loop
wdApp.Quit
MsgBox "Готово!"
End Sub

иерархия сохранения файла нечто похожим : Есть к примеру С:\новая папка\ в ней есть 2 папки (шаблоны и готовые документы), сейчас же файлы сохраняется в ту же папку где excel файлам я создал папку "Готовые документы" ,как нечто временное что б файлы не смешивались, но необходимо сохранять на уровень выше в папке "Готовые документы". везде решают проблему точным указанием папки на компьютере, но такой вариант не подходит т.к будет файл с шаблонами перемещаться на разные компьютеры и у каждого пользователя своя иерархия и будет все сбиваться и макрос не будет работать.

постарался внятно все объяснить))

Заранее благодарен за вашу неоценимую помощь!!!!!!
 
 
 
#2
20.04.2021 03:03:51
Цитата
empty написал:
необходимо сохранять на уровень выше
Как вариант, можно получить путь к папке на уровень выше таким способом
Код
Sub test()
HomeDir$ = ThisWorkbook.Path
a = Split(HomeDir$, "\")
b = Len(a(UBound(a))) + 1
c = Left(HomeDir$, Len(HomeDir$) - b)
MsgBox c
End Sub
 
 
 
#3
20.04.2021 20:55:09
спасибо за наводку, пошел чутка по другому пути и все сработало)) оставлю тут мало ли кому пригодится!
Код
Sub AKT()
    Dim wdApp As Object
    Dim wdDoc As Object
 
HomeDir$ = ThisWorkbook.Path
HomeDir2$ = Left(HomeDir$, InStrRev(HomeDir$, "\")) & "Готовые документы"
 
Set wdApp = CreateObject("Word.Application")
    i% = 3
Do
    If Cells(i%, 1).Value = "" Then Exit Do
    If Cells(i%, 1).Value <> "" Then
    
Название$ = Cells(i%, 1).Value
Производитель$ = Cells(i%, 2).Value
Центр$ = Cells(i%, 3).Value
AG$ = Cells(i%, 4).Value
AT$ = Cells(i%, 5).Value

DataC$ = Date

FileCopy HomeDir$ + "\AKT.doc", HomeDir2$ & "\Акт " + Название$ + "_" + Производитель$ + "_" + DataC$ + ".doc"
Set wdDoc = wdApp.Documents.Open(HomeDir2$ & "\Акт " + Название$ + "_" + Производитель$ + "_" + DataC$ + ".doc")


wdDoc.Range.Find.Execute FindText:="&date", Replacewith:=DataC$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&ID", Replacewith:=Название$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&OOO", Replacewith:=Производитель$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&Centr", Replacewith:=Центр$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&AG", Replacewith:=AG$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&AT", Replacewith:=AT$, Replace:=2
wdDoc.Range.Find.Execute Replace:=wdReplaceALL


wdDoc.Save
wdDoc.Close
End If
i% = i% + 1
Loop
wdApp.Quit
MsgBox "Готово!"
End Sub
Изменено: empty - 20.04.2021 20:55:38
 
 
 
Страницы: 1
Наверх