Добрый день! Есть макрос, который делает автозаполнение документа и сохраняет результат в одну общую папку с названием "Предложения, сделанные ... число, время" Хочу сделать, чтобы каждый файл сохранялся в отдельную папку с названием равным первому столбику, а в случае, если такая папка уже существует, просто добавлял новый файл в нее. Что нужно видоизменить? Подозреваю, что вопрос не сложный...
Sub СформироватьПредложения() ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона) НоваяПапка = NewFolderName & Application.PathSeparator Dim row As Range, pi As New ProgressIndicator r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2 If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
pi.Show "Формирование предложений": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application ' c подключением библиотеки Word Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application") ' без подключения библиотеки Word
For Each row In ActiveSheet.Rows("3:" & r) With row ФИО = Trim$(.Cells(1)) & " " & Trim$(.Cells(2)) & " " & Trim$(.Cells(4)) Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов
pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО For i = 1 To КоличествоОбрабатываемыхСтолбцов FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
' так почему-то заменяет не всё (не затрагивает таблицу) 'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
pi.line3 = "Заменяется поле " & FindText With WD.Range.Find .Text = FindText .Replacement.Text = ReplaceText .Forward = True .Wrap = 1 .Format = False: .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=2 End With DoEvents Next i pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " " WD.SaveAs Filename: WD.Close False: DoEvents p = p + a End With Next row
pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " " WA.Quit False: pi.Hide msg = "Сформировано " & rc & " предложений. Все они находятся в папке" & vbNewLine & НоваяПапка MsgBox msg, vbInformation, "Готово" End Sub
Function NewFolderName() As String NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Предложения, сформированные " & Get_Now) 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]
Добрый день! Есть макрос, который делает автозаполнение документа и сохраняет результат в одну общую папку с названием "Предложения, сделанные ... число, время" Хочу сделать, чтобы каждый файл сохранялся в отдельную папку с названием равным первому столбику, а в случае, если такая папка уже существует, просто добавлял новый файл в нее. Что нужно видоизменить? Подозреваю, что вопрос не сложный...
Sub СформироватьПредложения() ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона) НоваяПапка = NewFolderName & Application.PathSeparator Dim row As Range, pi As New ProgressIndicator r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2 If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
pi.Show "Формирование предложений": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application ' c подключением библиотеки Word Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application") ' без подключения библиотеки Word
For Each row In ActiveSheet.Rows("3:" & r) With row ФИО = Trim$(.Cells(1)) & " " & Trim$(.Cells(2)) & " " & Trim$(.Cells(4)) Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов
pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО For i = 1 To КоличествоОбрабатываемыхСтолбцов FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
' так почему-то заменяет не всё (не затрагивает таблицу) 'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
pi.line3 = "Заменяется поле " & FindText With WD.Range.Find .Text = FindText .Replacement.Text = ReplaceText .Forward = True .Wrap = 1 .Format = False: .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=2 End With DoEvents Next i pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " " WD.SaveAs Filename: WD.Close False: DoEvents p = p + a End With Next row
pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " " WA.Quit False: pi.Hide msg = "Сформировано " & rc & " предложений. Все они находятся в папке" & vbNewLine & НоваяПапка MsgBox msg, vbInformation, "Готово" End Sub
Function NewFolderName() As String NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Предложения, сформированные " & Get_Now) 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
Переформулирую - папка должна называться по значению в первом столбике, т.е. по наименованию фирмы. Сейчас макрос называет итоговые вордовские файлы подобным образом, а мне нужно, чтобы файлы улетали не в общую папку, а в папку, предназначенную для каждой ОООшки отдельно, т.е. по итогу все файлы каждой компании будут в одной папке Как то так
Переформулирую - папка должна называться по значению в первом столбике, т.е. по наименованию фирмы. Сейчас макрос называет итоговые вордовские файлы подобным образом, а мне нужно, чтобы файлы улетали не в общую папку, а в папку, предназначенную для каждой ОООшки отдельно, т.е. по итогу все файлы каждой компании будут в одной папке Как то такcatniponfire
Sub СформироватьПредложения() Dim iCount As Long ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
Dim row As Range, pi As New ProgressIndicator r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2 If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
pi.Show "Формирование предложений": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application ' c подключением библиотеки Word Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application") ' без подключения библиотеки Word
For Each row In ActiveSheet.Rows("3:" & r) With row ФИО = Trim$(.Cells(1)) & " " & Trim$(.Cells(2)) & " " & Trim$(.Cells(4)) НоваяПапка = NewFolderName(Cells(row.row, 1).Value) & Application.PathSeparator Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов
pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО For i = 1 To КоличествоОбрабатываемыхСтолбцов FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
' так почему-то заменяет не всё (не затрагивает таблицу) 'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
pi.line3 = "Заменяется поле " & FindText With WD.Range.Find .Text = FindText .Replacement.Text = ReplaceText .Forward = True .Wrap = 1 .Format = False: .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=2 End With DoEvents Next i pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " " WD.SaveAs Filename: WD.Close False: DoEvents p = p + a End With iCount = iCount + 1 Next row
pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " " WA.Quit False: pi.Hide msg = "Количество сформированных предложений: " & iCount & ". Все они находятся в соответствующих папках" MsgBox msg, vbInformation, "Готово" End Sub
Function NewFolderName(str1 As String) As String NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, str1) If Not CreateObject("Scripting.FileSystemObject").FolderExists(NewFolderName) Then MkDir NewFolderName End If End Function
[/vba]
Ну так изменил 2 процедуры [vba]
Код
Sub СформироватьПредложения() Dim iCount As Long ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
Dim row As Range, pi As New ProgressIndicator r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2 If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
pi.Show "Формирование предложений": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application ' c подключением библиотеки Word Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application") ' без подключения библиотеки Word
For Each row In ActiveSheet.Rows("3:" & r) With row ФИО = Trim$(.Cells(1)) & " " & Trim$(.Cells(2)) & " " & Trim$(.Cells(4)) НоваяПапка = NewFolderName(Cells(row.row, 1).Value) & Application.PathSeparator Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов
pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО For i = 1 To КоличествоОбрабатываемыхСтолбцов FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
' так почему-то заменяет не всё (не затрагивает таблицу) 'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
pi.line3 = "Заменяется поле " & FindText With WD.Range.Find .Text = FindText .Replacement.Text = ReplaceText .Forward = True .Wrap = 1 .Format = False: .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=2 End With DoEvents Next i pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " " WD.SaveAs Filename: WD.Close False: DoEvents p = p + a End With iCount = iCount + 1 Next row
pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " " WA.Quit False: pi.Hide msg = "Количество сформированных предложений: " & iCount & ". Все они находятся в соответствующих папках" MsgBox msg, vbInformation, "Готово" End Sub
Function NewFolderName(str1 As String) As String NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, str1) If Not CreateObject("Scripting.FileSystemObject").FolderExists(NewFolderName) Then MkDir NewFolderName End If End Function