Доброго времени суток. Так как в VBA я полный ноль, то обращаюсь к Вам, специалистам. Задача у меня следующая. Необходимо сохранить листы "Алюмаш", "ПолимерКолор" и "Reynaers" в отдельные книги по определённому адресу. В принципе макрос я подходящий нашел в интернете, единственное что хотелось бы доработать:
1. при выполнении макроса должно появляться окно с запросом на ввод номера заявки и даты, которые должны записаться на листы в А1 и А2 на каждый лист 2. при охранении листов как отдельные книги имя фала должно формироваться из номера заявки&даты заявки&имени листа 3. в созданных книгах необходимо разорвать подключения на листах "Алюмаш", "ПолимерКолор" и "Reynaers", что-то типа «ActiveWorkbook.Connections("Запрос — ПолимерКолор").Delete»
Заранее благодари за помощь
Доброго времени суток. Так как в VBA я полный ноль, то обращаюсь к Вам, специалистам. Задача у меня следующая. Необходимо сохранить листы "Алюмаш", "ПолимерКолор" и "Reynaers" в отдельные книги по определённому адресу. В принципе макрос я подходящий нашел в интернете, единственное что хотелось бы доработать:
1. при выполнении макроса должно появляться окно с запросом на ввод номера заявки и даты, которые должны записаться на листы в А1 и А2 на каждый лист 2. при охранении листов как отдельные книги имя фала должно формироваться из номера заявки&даты заявки&имени листа 3. в созданных книгах необходимо разорвать подключения на листах "Алюмаш", "ПолимерКолор" и "Reynaers", что-то типа «ActiveWorkbook.Connections("Запрос — ПолимерКолор").Delete»
Отлично все работает. Небольшая доработка. Как сделать так чтобы запросы перед выполнением макроса обновлялись. Думал сам смогу запихнуть в код, но выдает ошибку
Отлично все работает. Небольшая доработка. Как сделать так чтобы запросы перед выполнением макроса обновлялись. Думал сам смогу запихнуть в код, но выдает ошибку
В макрос внесено еще одно изменение, поэтому используйте эту версию (неправильно удалялись подключения).
[vba]
Код
Sub макрос() Dim bk As Workbook, sh As Worksheet, collShNames As New Collection Dim i As Long, ii As Long 'сюда записывайте имена листов, для которых нужно создать файлы collShNames.Add Item:="Алюмаш" collShNames.Add Item:="ПолимерКолор" collShNames.Add Item:="Reynaers" Application.ScreenUpdating = False 'обновление всех подключений в исходном файле ActiveWorkbook.RefreshAll Set bk = ActiveWorkbook For i = 1 To collShNames.Count Set sh = bk.Worksheets(collShNames(i)) sh.Copy For ii = ActiveWorkbook.Connections.Count To 1 Step -1 ActiveWorkbook.Connections(ii).Delete Next ii ActiveSheet.Range("B1").Value = arrUF(1) ActiveSheet.Range("B2").Value = arrUF(2) ActiveWorkbook.SaveAs "N:\Home\Sbit\PP\VNaidyuk\Примеры\удалить" & "\" & _ arrUF(1) & "_" & arrUF(2) & "_" & sh.Name & ".xlsx" ActiveWorkbook.Close SaveChanges:=False Next Application.ScreenUpdating = True MsgBox "Готово.", vbInformation End Sub
[/vba]
В макрос внесено еще одно изменение, поэтому используйте эту версию (неправильно удалялись подключения).
[vba]
Код
Sub макрос() Dim bk As Workbook, sh As Worksheet, collShNames As New Collection Dim i As Long, ii As Long 'сюда записывайте имена листов, для которых нужно создать файлы collShNames.Add Item:="Алюмаш" collShNames.Add Item:="ПолимерКолор" collShNames.Add Item:="Reynaers" Application.ScreenUpdating = False 'обновление всех подключений в исходном файле ActiveWorkbook.RefreshAll Set bk = ActiveWorkbook For i = 1 To collShNames.Count Set sh = bk.Worksheets(collShNames(i)) sh.Copy For ii = ActiveWorkbook.Connections.Count To 1 Step -1 ActiveWorkbook.Connections(ii).Delete Next ii ActiveSheet.Range("B1").Value = arrUF(1) ActiveSheet.Range("B2").Value = arrUF(2) ActiveWorkbook.SaveAs "N:\Home\Sbit\PP\VNaidyuk\Примеры\удалить" & "\" & _ arrUF(1) & "_" & arrUF(2) & "_" & sh.Name & ".xlsx" ActiveWorkbook.Close SaveChanges:=False Next Application.ScreenUpdating = True MsgBox "Готово.", vbInformation End Sub
[/vba] Суть вообще какая. Есть книга с запросами. Мне необходимо обновить все запросы при открытии. С этим вопросов нет, я включу обновление при открытии книги. А вот потом в одну таблицу (ЗаявкаШаблон) вручную будут вноситься данные, которые должны при выполнении макроса 1. обновляться в запросах ЗаявкаШаблон СпрНоменклатура Алюмаш ПолимерКолор Reynaers
другие запросы не нужно обновлять 2. Сохранять листы в отдельные книги Алюмаш ПолимерКолор Reynaers 3. Это только сейчас понял, Переименовать листы в новосозданных книгах (Алюмаш, ПолимерКолор, Reynaers) в одно имя, например "Лист1" Файл весит 500 кб в архиве, приложить не могу
Karataev, Здравствуйте. Ругается на [vba]
Код
ActiveWorkbook.Connections(ii).Delete
[/vba] Суть вообще какая. Есть книга с запросами. Мне необходимо обновить все запросы при открытии. С этим вопросов нет, я включу обновление при открытии книги. А вот потом в одну таблицу (ЗаявкаШаблон) вручную будут вноситься данные, которые должны при выполнении макроса 1. обновляться в запросах ЗаявкаШаблон СпрНоменклатура Алюмаш ПолимерКолор Reynaers
другие запросы не нужно обновлять 2. Сохранять листы в отдельные книги Алюмаш ПолимерКолор Reynaers 3. Это только сейчас понял, Переименовать листы в новосозданных книгах (Алюмаш, ПолимерКолор, Reynaers) в одно имя, например "Лист1" Файл весит 500 кб в архиве, приложить не могуmechanix85
[/vba] работает асинхронно. То есть макрос не дожидается, когда эта строка сделает свою работу: [vba]
Код
ActiveWorkbook.RefreshAll
[/vba] и переходит к следующей строке. Дойдя до строки: [vba]
Код
ActiveWorkbook.Connections(ii).Delete
[/vba] возникает конфликт, т.к. объекты "Connections" еще обрабатываются строкой: [vba]
Код
ActiveWorkbook.RefreshAll
[/vba] У меня подключения не обновляются, т.к. в подключениях указаны файлы, которых у меня нет. Может быть из-ха этого проблема у меня. Если у Вас есть файлы, то может быть не будет такой проблемы.
У меня ошибка возникает в этой строке: [vba]
Код
ActiveWorkbook.Connections(ii).Delete
[/vba] Если используется эта строка: [vba]
Код
ActiveWorkbook.RefreshAll
[/vba] Я так понимаю, что эта строка: [vba]
Код
ActiveWorkbook.RefreshAll
[/vba] работает асинхронно. То есть макрос не дожидается, когда эта строка сделает свою работу: [vba]
Код
ActiveWorkbook.RefreshAll
[/vba] и переходит к следующей строке. Дойдя до строки: [vba]
Код
ActiveWorkbook.Connections(ii).Delete
[/vba] возникает конфликт, т.к. объекты "Connections" еще обрабатываются строкой: [vba]
Код
ActiveWorkbook.RefreshAll
[/vba] У меня подключения не обновляются, т.к. в подключениях указаны файлы, которых у меня нет. Может быть из-ха этого проблема у меня. Если у Вас есть файлы, то может быть не будет такой проблемы.Karataev
Сообщение отредактировал Karataev - Суббота, 23.12.2017, 14:51
Нашел такое: вкладка "Данные" - Подключения - выберите первое подключение - Свойства - вкладка "Использование" - снимите флажок "Фоновое обновление". Может быть эта опция включает / отключает синхронный / асинхронный способ обновления. Я в Вашем файле у всех подключений снял этот флажок и ошибки в макросе не произошло. Хотя такое поведение нелогично, ошибка должна была быть здесь: [vba]
Код
ActiveWorkbook.RefreshAll
[/vba]
Нашел такое: вкладка "Данные" - Подключения - выберите первое подключение - Свойства - вкладка "Использование" - снимите флажок "Фоновое обновление". Может быть эта опция включает / отключает синхронный / асинхронный способ обновления. Я в Вашем файле у всех подключений снял этот флажок и ошибки в макросе не произошло. Хотя такое поведение нелогично, ошибка должна была быть здесь: [vba]
Вот такой вариант попробуйте. Я чуть глубже разобрался в подключениях. У Вас в файле используется Power Query, оно относится в объекте "Connection" к объекту "OLEDBConnection", в котором больше инструментов для работы с подключением.
[vba]
Код
Sub макрос() Dim bk As Workbook, sh As Worksheet, collShNames As New Collection Dim i As Long, ii As Long 'сюда записывайте имена листов, для которых нужно создать файлы collShNames.Add Item:="Алюмаш" collShNames.Add Item:="ПолимерКолор" collShNames.Add Item:="Reynaers" Application.ScreenUpdating = False Set bk = ActiveWorkbook For i = 1 To collShNames.Count Set sh = bk.Worksheets(collShNames(i)) sh.Copy For ii = ActiveWorkbook.Connections.Count To 1 Step -1 If ActiveWorkbook.Connections(ii).OLEDBConnection.IsConnected = True Then ActiveWorkbook.Connections(ii).OLEDBConnection.BackgroundQuery = False ActiveWorkbook.Connections(ii).Refresh End If ActiveWorkbook.Connections(ii).Delete Next ii ActiveSheet.Range("B1").Value = arrUF(1) ActiveSheet.Range("B2").Value = arrUF(2) ActiveWorkbook.SaveAs "N:\Home\Sbit\PP\VNaidyuk\Примеры\удалить" & "\" & _ arrUF(1) & "_" & arrUF(2) & "_" & sh.Name & ".xlsx" ActiveWorkbook.Close SaveChanges:=False Next Application.ScreenUpdating = True MsgBox "Готово.", vbInformation End Sub
[/vba]
Вот такой вариант попробуйте. Я чуть глубже разобрался в подключениях. У Вас в файле используется Power Query, оно относится в объекте "Connection" к объекту "OLEDBConnection", в котором больше инструментов для работы с подключением.
[vba]
Код
Sub макрос() Dim bk As Workbook, sh As Worksheet, collShNames As New Collection Dim i As Long, ii As Long 'сюда записывайте имена листов, для которых нужно создать файлы collShNames.Add Item:="Алюмаш" collShNames.Add Item:="ПолимерКолор" collShNames.Add Item:="Reynaers" Application.ScreenUpdating = False Set bk = ActiveWorkbook For i = 1 To collShNames.Count Set sh = bk.Worksheets(collShNames(i)) sh.Copy For ii = ActiveWorkbook.Connections.Count To 1 Step -1 If ActiveWorkbook.Connections(ii).OLEDBConnection.IsConnected = True Then ActiveWorkbook.Connections(ii).OLEDBConnection.BackgroundQuery = False ActiveWorkbook.Connections(ii).Refresh End If ActiveWorkbook.Connections(ii).Delete Next ii ActiveSheet.Range("B1").Value = arrUF(1) ActiveSheet.Range("B2").Value = arrUF(2) ActiveWorkbook.SaveAs "N:\Home\Sbit\PP\VNaidyuk\Примеры\удалить" & "\" & _ arrUF(1) & "_" & arrUF(2) & "_" & sh.Name & ".xlsx" ActiveWorkbook.Close SaveChanges:=False Next Application.ScreenUpdating = True MsgBox "Готово.", vbInformation End Sub