Private Sub CommandButton1_Click()
Me.Copy
iPrompt = "Введите имя файла": iTitle = "Диалоговое окно"
FileName: iFileName = InputBox(iPrompt, iTitle)
If iFileName = "" Then
iPrompt = "Пора вводить имя файла"
iTitle = "Хватит дурачиться"
GoTo FileName
Else
iFullName = Application.DefaultFilePath & "\" & iFileName & ".xls"
If Dir(iFullName) <> "" Then
iPrompt = "Введите новое имя файла"
iTitle = "Подберите уникальное имя"
GoTo FileName
End If
End If
ActiveWorkbook.SaveAs FileName:=iFullName
End Sub
Лист Excel в отдельный файл
Есть одна кнопка. По нажатию на нее надо чтобы этот лист со всеми форматами ( собственно областью печати) сохранялся в отдельный файл. Желательно чтобы имя нового файла можно было бы ввести.
Заранее спасибо.
Заранее спасибо.
Если под кнопкой Вы подразумеваете элемент ActiveX, то Вы можете использовать что-то типа :
Примечание :
При использовании данного метода существует вероятность, что данные в ячейках, содержимое которых превышает 255 символов, будут усечены.
Код:
Примечание :
При использовании данного метода существует вероятность, что данные в ячейках, содержимое которых превышает 255 символов, будут усечены.
Спасибо, это здорово, но все же немного не то.
Надо чтобы в той-же папке появлялся отдельный файл Эксель, в котором будет только один лист (нужный). А файл в котором работают так и оставался как есть.
Сейчас же получается что просто переименовываетс файл (книга) в которой сейчас работают, причем сохраняется непонятно где или надо сохранять именно вручную (т.е. перименовывается только текущий файл и все)
Надо чтобы в той-же папке появлялся отдельный файл Эксель, в котором будет только один лист (нужный). А файл в котором работают так и оставался как есть.
Сейчас же получается что просто переименовываетс файл (книга) в которой сейчас работают, причем сохраняется непонятно где или надо сохранять именно вручную (т.е. перименовывается только текущий файл и все)
При нажатии кнопки (которая представляет собой элемент управления ActiveX и располагается на ячейках рабочего листа) создаётся отдельная рабочая книга, состоящая всего из одного листа, того самого в котором Вы нажали на кнопку.
Далее, после ввода имени файла, эта рабочая книга сохраняется не неизвестно куда, а в папку по умолчанию, как правило \Мои документы\
Так что всё совпадает с Вами требованиями, за исключением папки сохранения, где я имел право свободу выбора, так как в первоначальном вопросе эта часть не обсуждалась.
Далее, после ввода имени файла, эта рабочая книга сохраняется не неизвестно куда, а в папку по умолчанию, как правило \Мои документы\
Так что всё совпадает с Вами требованиями, за исключением папки сохранения, где я имел право свободу выбора, так как в первоначальном вопросе эта часть не обсуждалась.
Извините, возможно я не совсем точно сформулировал вопрос. Но нужно чтобы сохранялся только один лист( можно сказать область печати этого листа), а сохраняется вся книга. ПРичем и с макросом и с кнопокой, короче вся. Куда помещается действительно не важно :-) упор не на место расположения, а на содержание листа.
А все понял, я сам накосячил, извините :-)
Лист действительно копируется вместе с кнопкой и макросом, который находится в модуле этого же листа, но это не противоречило Вашим первоначальным требованиям. Если этого нужно избежать, то можно использовать что-то вроде :
Можно даже так, но первый пример, в основном был с прицелом на дальнейшее продолжение кода.
Код:
Private Sub CommandButton1_Click()
With Workbooks.Add(xlWBATWorksheet)
Me.Cells.Copy Destination:=.Worksheets(1).Cells
End With
End Sub
With Workbooks.Add(xlWBATWorksheet)
Me.Cells.Copy Destination:=.Worksheets(1).Cells
End With
End Sub
Можно даже так, но первый пример, в основном был с прицелом на дальнейшее продолжение кода.
Код:
Private Sub CommandButton1_Click()
Me.Cells.Copy Destination:=Workbooks.Add(xlWBATWorksheet).Worksheets(1).Cells
End Sub
Me.Cells.Copy Destination:=Workbooks.Add(xlWBATWorksheet).Worksheets(1).Cells
End Sub
Ценные сведения, учту. Я решил избежать этого еще проще :-) я порсто перенес весь макрос с кнопкой на другой лист и все :-)
Короче говоря, Вы просто оставили самый первый вариант ...
Цитата:
Originally posted by pashulka
Короче говоря, Вы просто оставили самый первый вариант ...
Короче говоря, Вы просто оставили самый первый вариант ...
Еще один вопрос назрел, как можно скопировать несколько листов, т.е. чтобы новая книга состояла не из одного листа отдельного а из 3 скажем.
Вариант I.
Вариант II.
Код:
Worksheets(Array(1, 2, 3)).Copy
Вариант II.
Код:
Worksheets(Array("Отчёт", "Список", "Мусор")).Copy
Если так делать то копируется весь лист (так и нужно было раньше), но теперь там есть код завязанный на другие листы книги и поэтому выскакивает ошибка. Т.е. надо копировать лист без кода. Вы предлагали как сделать это раньше. Но есть еще один момент, формулы с такого листа обращаются к файлу источнику. Т.е. там в каждой ячейке вместе с формулой появляется путь к файлу. Было бы идеально копировать именно значения из ячеек. Заранее спасибо.
Вот пример копирования, где формулы будут заменены на значения, которые они возвращают. Пример для двух рабочих листов, расположенных в одной рабочей книге, Вам нужно только изменить ссылки на об'екты.
Код:
Worksheets(1).Range("B1:E10").Copy
Worksheets(2).Range("G10:J19").PasteSpecial xlPasteValues
Worksheets(2).Range("G10:J19").PasteSpecial xlPasteValues
В том-то и проблема я не знаю как это сделать для другой книги.
Private Sub CommandButton1_Click()
Worksheets(Array("Äàííûå", "Ãðàôèê")).Copy
iPrompt = "Ââåäèòå èìÿ ôàéëà": iTitle = "Äèàëîãîâîå îêíî"
FileName: iFileName = InputBox(iPrompt, iTitle)
If iFileName = "" Then
iPrompt = "Ïîðà ââîäèòü èìÿ ôàéëà"
iTitle = "Õâàòèò äóðà÷èòüñÿ"
GoTo FileName
Else
iFullName = Application.DefaultFilePath & "\" & iFileName & ".xls"
If Dir(iFullName) <> "" Then
iPrompt = "Ââåäèòå íîâîå èìÿ ôàéëà"
iTitle = "Ïîäáåðèòå óíèêàëüíîå èìÿ"
GoTo FileName
End If
End If
ActiveWorkbook.SaveAs FileName:=iFullName
ActiveWorkbook.Worksheets("Äàííûå").Range("a1:f53").Copy
ActiveWorkbook.Worksheets("Äàííûå").Range("a1:f53").PasteSpecial xlPasteValues
ActiveWorkbook.Worksheets("Ãðàôèê").Range("a1:f53").Copy
ActiveWorkbook.Worksheets("Ãðàôèê").Range("a1:f53").PasteSpecial xlPasteValues
ActiveWorkbook.SaveAs FileName:=iFullName
End Sub
сделал что-то врде этого. Но так не работает.
Надо сразу чтобы в новой книге появлялись ячейки со значениями, а так муть какая-то происходит :-(
Private Sub CommandButton1_Click()
Worksheets(Array("Äàííûå", "Ãðàôèê")).Copy
iPrompt = "Ââåäèòå èìÿ ôàéëà": iTitle = "Äèàëîãîâîå îêíî"
FileName: iFileName = InputBox(iPrompt, iTitle)
If iFileName = "" Then
iPrompt = "Ïîðà ââîäèòü èìÿ ôàéëà"
iTitle = "Õâàòèò äóðà÷èòüñÿ"
GoTo FileName
Else
iFullName = Application.DefaultFilePath & "\" & iFileName & ".xls"
If Dir(iFullName) <> "" Then
iPrompt = "Ââåäèòå íîâîå èìÿ ôàéëà"
iTitle = "Ïîäáåðèòå óíèêàëüíîå èìÿ"
GoTo FileName
End If
End If
ActiveWorkbook.SaveAs FileName:=iFullName
ActiveWorkbook.Worksheets("Äàííûå").Range("a1:f53").Copy
ActiveWorkbook.Worksheets("Äàííûå").Range("a1:f53").PasteSpecial xlPasteValues
ActiveWorkbook.Worksheets("Ãðàôèê").Range("a1:f53").Copy
ActiveWorkbook.Worksheets("Ãðàôèê").Range("a1:f53").PasteSpecial xlPasteValues
ActiveWorkbook.SaveAs FileName:=iFullName
End Sub
сделал что-то врде этого. Но так не работает.
Надо сразу чтобы в новой книге появлялись ячейки со значениями, а так муть какая-то происходит :-(
Пример именно с копированием.
Код:
iCopyList = Array("Отчёт", "Список", "Мусор")
iOldCountList = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 3
With Workbooks.Add
For Each iList In ThisWorkbook.Worksheets(iCopyList)
iList.Cells.Copy
iCount = iCount + 1
With .Worksheets(iCount)
.Name = iList.Name
.Cells.PasteSpecial xlPasteValues
End With
Next
End With
Application.SheetsInNewWorkbook = iOldCountList
iOldCountList = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 3
With Workbooks.Add
For Each iList In ThisWorkbook.Worksheets(iCopyList)
iList.Cells.Copy
iCount = iCount + 1
With .Worksheets(iCount)
.Name = iList.Name
.Cells.PasteSpecial xlPasteValues
End With
Next
End With
Application.SheetsInNewWorkbook = iOldCountList
Цитата:
Originally posted by pashulka
Пример именно с копированием.
Пример именно с копированием.
Код:
iCopyList = Array("Отчёт", "Список", "Мусор")
iOldCountList = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 3
With Workbooks.Add
For Each iList In ThisWorkbook.Worksheets(iCopyList)
iList.Cells.Copy
iCount = iCount + 1
With .Worksheets(iCount)
.Name = iList.Name
.Cells.PasteSpecial xlPasteValues
End With
Next
End With
Application.SheetsInNewWorkbook = iOldCountList
iOldCountList = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 3
With Workbooks.Add
For Each iList In ThisWorkbook.Worksheets(iCopyList)
iList.Cells.Copy
iCount = iCount + 1
With .Worksheets(iCount)
.Name = iList.Name
.Cells.PasteSpecial xlPasteValues
End With
Next
End With
Application.SheetsInNewWorkbook = iOldCountList
БОЖЕСТВЕННО - ТО что нужно :-)
Новый вопрос, как сделать чтобы рисунок находящийся на листе тоже кпировался, и область печати тоже.
Т.е. на новом листе нет никакой области печати. а хотелось бы оставить ту которая задана на исходнике.
Т.е. на новом листе нет никакой области печати. а хотелось бы оставить ту которая задана на исходнике.
Для того, чтобы скопировать рисунок можно использовать один из первых вариантов ***, а затем заменить формулы на значения, которые эти формулы возвращают.
***
Для того, чтобы установить нужную область печати :
***
Код:
Worksheets(1).Cells.Copy Destination:=Worksheets(2).Cells
Для того, чтобы установить нужную область печати :
Код:
Worksheets(2).PageSetup.PrintArea = Worksheets(1).PageSetup.PrintArea
Вот один из возможных вариантов решения Вашей задачи :
Код:
iCopyList = Array("Отчёт", "Список", "Мусор")
iOldCountList = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 3
With Workbooks.Add
For Each iList In ThisWorkbook.Worksheets(iCopyList)
iCount = iCount + 1
iList.Cells.Copy Destination:=.Worksheets(iCount).Cells
With .Worksheets(iCount)
.Name = iList.Name
.UsedRange.Value = iList.UsedRange.Value
.PageSetup.PrintArea = iList.PageSetup.PrintArea
End With
Next
End With
Application.SheetsInNewWorkbook = iOldCountList
iOldCountList = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 3
With Workbooks.Add
For Each iList In ThisWorkbook.Worksheets(iCopyList)
iCount = iCount + 1
iList.Cells.Copy Destination:=.Worksheets(iCount).Cells
With .Worksheets(iCount)
.Name = iList.Name
.UsedRange.Value = iList.UsedRange.Value
.PageSetup.PrintArea = iList.PageSetup.PrintArea
End With
Next
End With
Application.SheetsInNewWorkbook = iOldCountList
С областью печати понятно , а как быть с ориентацией и масштабом листа?
Код:
With ActiveSheet.PageSetup
.Orientation = xlLandscape 'xlPortrait 'Ориентация
.Zoom = 75 'Масштаб
End With
.Orientation = xlLandscape 'xlPortrait 'Ориентация
.Zoom = 75 'Масштаб
End With
Спасибо, но столкнулся с другой проблемой:
При закрытии основной книги выскакивает сначала 2 раза - Рисунок слишком велик и будет усечен, после - Недостаточно ресурсов. Выберите меньше или закройте приложения. Как бы это обойти.
И еще вопрос как будет выглядеть код если нужно сохранить один лист в отдельный файл, а не массив листов, возможно это поможет решить эту проблему.
P.S. Книги пробывал пересоздавать заново без рисунков книгу, должного результата не получил, как я понимаю проблема в самом методе копирования.
Заранее спасибо за помощь.
При закрытии основной книги выскакивает сначала 2 раза - Рисунок слишком велик и будет усечен, после - Недостаточно ресурсов. Выберите меньше или закройте приложения. Как бы это обойти.
И еще вопрос как будет выглядеть код если нужно сохранить один лист в отдельный файл, а не массив листов, возможно это поможет решить эту проблему.
P.S. Книги пробывал пересоздавать заново без рисунков книгу, должного результата не получил, как я понимаю проблема в самом методе копирования.
Заранее спасибо за помощь.
С проблемой усечения рисунка, лично я, никогда не сталкивался, а что касается сохранения одного единственного листа, то смотрите этот топик, только с самого начала.
вопрос по этому коду
Sub CommandButton1_Click()
Me.Copy
iPrompt = "Введите имя файла": iTitle = "Диалоговое окно"
FileName: iFileName = InputBox(iPrompt, iTitle)
If iFileName = "" Then
iPrompt = "Пора вводить имя файла"
iTitle = "Хватит дурачиться"
GoTo FileName
Else
iFullName = Application.DefaultFilePath & "\" & iFileName & ".xls"
If Dir(iFullName) <> "" Then
iPrompt = "Введите новое имя файла"
iTitle = "Подберите уникальное имя"
GoTo FileName
End If
End If
ActiveWorkbook.SaveAs FileName:=iFullName
End Sub
подскажите пожалуйста как сделать чтоб лист сохранялся не по умолчанию а в определённую папку.....заранее спасибо
Sub CommandButton1_Click()
Me.Copy
iPrompt = "Введите имя файла": iTitle = "Диалоговое окно"
FileName: iFileName = InputBox(iPrompt, iTitle)
If iFileName = "" Then
iPrompt = "Пора вводить имя файла"
iTitle = "Хватит дурачиться"
GoTo FileName
Else
iFullName = Application.DefaultFilePath & "\" & iFileName & ".xls"
If Dir(iFullName) <> "" Then
iPrompt = "Введите новое имя файла"
iTitle = "Подберите уникальное имя"
GoTo FileName
End If
End If
ActiveWorkbook.SaveAs FileName:=iFullName
End Sub
подскажите пожалуйста как сделать чтоб лист сохранялся не по умолчанию а в определённую папку.....заранее спасибо