Здравствуйте. Искал код уже готовый по импорту страниц из другого файла. Кое какой нашел но у меня не получается его сделать рабочим. Ругается прямо на первую строку "Sub ttt()"
Короче есть много листов которые хотел бы научится импортировать в основной файл. Файл из которого хочу взять страницы всегда может лежать в одном и том же месте и называться одинаково. Единственное в листах которые переносим из книги в книгу должны сохранится все формулы без изменений.
Заметил такую вещь что я даже не могу сохранить страницы с неработающими ссылкам ( Как быть в такой ситуации ? В макросе менять все формулы на не формулы и обратно ?
[vba]
Код
Sub ttt() Set objExcel = New Excel.Application Set wbhidden = objExcel.Workbooks.Open("C:\Users\Ultramode\Desktop\шмойства\Новая папка\разделение этикеток\Этикетки Овощи 11.11.2014 Вторник.xlsm")
wbhidden.Close ' обязательно при выходе из кода Set objExcel = Nothing ' обязательно при выходе из кода End Sub
[/vba]
и Нашел рабочий макрос:
[vba]
Код
Sub CombineWorkbooks() Dim FilesToOpen Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _ MultiSelect:=True, Title:="Files to Merge") If TypeName(FilesToOpen) = "Boolean" Then MsgBox "Не выбрано ни одного файла!" GoTo ExitHandler End If x = 1 While x <= UBound(FilesToOpen) Workbooks.Open Filename:=FilesToOpen(x) Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) x = x + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub
[/vba]
Но как быть теперь с ссылками которые разрушаются ?
Здравствуйте. Искал код уже готовый по импорту страниц из другого файла. Кое какой нашел но у меня не получается его сделать рабочим. Ругается прямо на первую строку "Sub ttt()"
Короче есть много листов которые хотел бы научится импортировать в основной файл. Файл из которого хочу взять страницы всегда может лежать в одном и том же месте и называться одинаково. Единственное в листах которые переносим из книги в книгу должны сохранится все формулы без изменений.
Заметил такую вещь что я даже не могу сохранить страницы с неработающими ссылкам ( Как быть в такой ситуации ? В макросе менять все формулы на не формулы и обратно ?
[vba]
Код
Sub ttt() Set objExcel = New Excel.Application Set wbhidden = objExcel.Workbooks.Open("C:\Users\Ultramode\Desktop\шмойства\Новая папка\разделение этикеток\Этикетки Овощи 11.11.2014 Вторник.xlsm")
wbhidden.Close ' обязательно при выходе из кода Set objExcel = Nothing ' обязательно при выходе из кода End Sub
[/vba]
и Нашел рабочий макрос:
[vba]
Код
Sub CombineWorkbooks() Dim FilesToOpen Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _ MultiSelect:=True, Title:="Files to Merge") If TypeName(FilesToOpen) = "Boolean" Then MsgBox "Не выбрано ни одного файла!" GoTo ExitHandler End If x = 1 While x <= UBound(FilesToOpen) Workbooks.Open Filename:=FilesToOpen(x) Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) x = x + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub
[/vba]
Но как быть теперь с ссылками которые разрушаются ?koyaanisqatsi
RAN, Так много страниц. А если их количество будет увеличиваться ? К тому же что бы работали эти листы придется в обоих книгах хранить листы с одинаковыми именами а как копировать листы с одинаковыми именами ? а потом тогда что удалять ? Пытался изучить как это можно решить через двуссыл но там не протягивается формула (
А через формат можно это решать ? Например в файле и которого надо брать все было бы в текстовом формате а при копировании листов задавать общий формат ?
Оригинально, что эксель позволяет себе менять формулы при удалении листа на который они ссылались, даже если ты страницу защитил паролем от изменений
RAN, Так много страниц. А если их количество будет увеличиваться ? К тому же что бы работали эти листы придется в обоих книгах хранить листы с одинаковыми именами а как копировать листы с одинаковыми именами ? а потом тогда что удалять ? Пытался изучить как это можно решить через двуссыл но там не протягивается формула (
А через формат можно это решать ? Например в файле и которого надо брать все было бы в текстовом формате а при копировании листов задавать общий формат ?
Оригинально, что эксель позволяет себе менять формулы при удалении листа на который они ссылались, даже если ты страницу защитил паролем от измененийkoyaanisqatsi
Сообщение отредактировал koyaanisqatsi - Воскресенье, 09.11.2014, 19:40
Sub CombineWorkbooks() Dim FilesToOpen Dim x As Integer Dim sh As Worksheet On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _ MultiSelect:=True, Title:="Files to Merge") If TypeName(FilesToOpen) = "Boolean" Then MsgBox "Не выбрано ни одного файла!" GoTo ExitHandler End If x = 1 While x <= UBound(FilesToOpen) With Workbooks.Open(Filename:=FilesToOpen(x)) For Each sh In .Worksheets sh.UsedRange.Replace what:="=", Replacement:="@@", LookAt:=xlPart sh.Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) .UsedRange.Replace what:="@@", Replacement:="=", LookAt:=xlPart End With Next .Saved = True .Close End With x = x + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub
[/vba]
Не проверял
[p.s.]Смущает Move. Может Copy?[/p.s.]
[vba]
Код
Sub CombineWorkbooks() Dim FilesToOpen Dim x As Integer Dim sh As Worksheet On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _ MultiSelect:=True, Title:="Files to Merge") If TypeName(FilesToOpen) = "Boolean" Then MsgBox "Не выбрано ни одного файла!" GoTo ExitHandler End If x = 1 While x <= UBound(FilesToOpen) With Workbooks.Open(Filename:=FilesToOpen(x)) For Each sh In .Worksheets sh.UsedRange.Replace what:="=", Replacement:="@@", LookAt:=xlPart sh.Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) .UsedRange.Replace what:="@@", Replacement:="=", LookAt:=xlPart End With Next .Saved = True .Close End With x = x + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub
RAN, Покажите пожалуйста. А то когда я начинаю сам что то правит вылезают только ошибки. А при записи макроса средствами экселя почему-то файл начинает лагать жестко. Могу пример показать как лагает.
RAN, Покажите пожалуйста. А то когда я начинаю сам что то правит вылезают только ошибки. А при записи макроса средствами экселя почему-то файл начинает лагать жестко. Могу пример показать как лагает.koyaanisqatsi
RAN, этот вариант насколько я понимаю работает. Надо будет поиграться потестить ) И да вы правы насчет муве выдает какой-то ерор хотя все равно работает. непонятно почему у меня не пахало. Вроде пробовал такой вариант.
RAN, этот вариант насколько я понимаю работает. Надо будет поиграться потестить ) И да вы правы насчет муве выдает какой-то ерор хотя все равно работает. непонятно почему у меня не пахало. Вроде пробовал такой вариант.koyaanisqatsi
Sub CombineWorkbooks() ' Dim FilesToOpen Dim x As Integer Dim sh As Worksheet On Error GoTo ErrHandler Application.ScreenUpdating = False ' FilesToOpen = Application.GetOpenFilename _ ' (FileFilter:="Microsoft Excel Files (*.xls*), *.xls*", _ ' MultiSelect:=True, Title:="Files to Merge") ' If TypeName(FilesToOpen) = "Boolean" Then ' MsgBox "Не выбрано ни одного файла!" ' GoTo ExitHandler ' End If ' x = 1 ' While x <= UBound(FilesToOpen) ' With Workbooks.Open(Filename:=FilesToOpen(x)) Dim FilesToOpen As String
FilesToOpen = "полный путь и имя файла"
With Workbooks.Open(Filename:=FilesToOpen) For Each sh In .Worksheets ' sh.UsedRange.Replace what:="=", Replacement:="@@", LookAt:=xlPart sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) .UsedRange.Replace what:="ёмаё", Replacement:="=", LookAt:=xlPart End With Next .Saved = True .Close End With ' x = x + 1 'Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub
[/vba]
[vba]
Код
Sub CombineWorkbooks() ' Dim FilesToOpen Dim x As Integer Dim sh As Worksheet On Error GoTo ErrHandler Application.ScreenUpdating = False ' FilesToOpen = Application.GetOpenFilename _ ' (FileFilter:="Microsoft Excel Files (*.xls*), *.xls*", _ ' MultiSelect:=True, Title:="Files to Merge") ' If TypeName(FilesToOpen) = "Boolean" Then ' MsgBox "Не выбрано ни одного файла!" ' GoTo ExitHandler ' End If ' x = 1 ' While x <= UBound(FilesToOpen) ' With Workbooks.Open(Filename:=FilesToOpen(x)) Dim FilesToOpen As String
FilesToOpen = "полный путь и имя файла"
With Workbooks.Open(Filename:=FilesToOpen) For Each sh In .Worksheets ' sh.UsedRange.Replace what:="=", Replacement:="@@", LookAt:=xlPart sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) .UsedRange.Replace what:="ёмаё", Replacement:="=", LookAt:=xlPart End With Next .Saved = True .Close End With ' x = x + 1 'Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub
RAN, А если ругается так "application-defined or objectdefined error" перекидывает одну страницу и глохнет с этой ошибкой Еще и так ругается "Automation error The object invoked has disconnected from its client" Это не из-за последних изменений а еще пока с предпоследней версией работал. Ща буду пробовать последний вариант, но скорее всего будет тоже самое.
Получилось с помощью первого макроса скопировать все листы. Хотя он и спрашивал про имена в книге (те что используются в диспетчере имен, а этого не хотелось бы). И получилось Ctrl+H заменить все "ёмаё" на "" Увидел что все работает. Осталось только научить макрос выполнять это не сложное действие и понять насколько это долго или быстро. 13.5к формул он меняет при этом.
RAN, А если ругается так "application-defined or objectdefined error" перекидывает одну страницу и глохнет с этой ошибкой Еще и так ругается "Automation error The object invoked has disconnected from its client" Это не из-за последних изменений а еще пока с предпоследней версией работал. Ща буду пробовать последний вариант, но скорее всего будет тоже самое.
Получилось с помощью первого макроса скопировать все листы. Хотя он и спрашивал про имена в книге (те что используются в диспетчере имен, а этого не хотелось бы). И получилось Ctrl+H заменить все "ёмаё" на "" Увидел что все работает. Осталось только научить макрос выполнять это не сложное действие и понять насколько это долго или быстро. 13.5к формул он меняет при этом.koyaanisqatsi
Сообщение отредактировал koyaanisqatsi - Понедельник, 10.11.2014, 01:46
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
