Новости:

Теперь на форум можно залогиниться / зарегистрироваться с помощью ВКонтакте. Уже существующие пользователи могут связать свою учетную запись с аккаунтом ВКонтакте одним кликом в профиле пользователя http://forum.msexcel.ru/index.php?action=profile;area=account

Главное меню

Копирование диапазона с сохранением форматов и размеров ячеек

Автор vladturbo, 21.01.2011, 22:41

« назад - далее »

vladturbo

ВОПРОС: Необходимо с помощью макроса копировать и вставлять (в другую книгу значения из диапазона данных сохраняя формат, размер и границы ячеек).
Копируется и вставляется все, кроме размеров (высоты и строки и ширины столбца)

Если использовать метод Cells.Select, к сожалению не работает метод Seltct
Допустим:
Sheets("Лист9").Select
Cells.Select
Selection.Copy...
...и далее по тексту Paste
так вот, при таком варианте Sheets("Лист9").Select выдает ошибку Debug


А при таком варианте не сохраняются размеры ячеек. Подскажите как быть?
Private Sub CommandButton7_Click()
Dim Msg As String, MyString As String
Dim Btns As Integer
Dim Title As String, Help As String
Dim NmbCont As Integer, Result As Integer
Title = " Формирование отчета !"
Msg = "ВНИМАНИЕ ! ПРИ ФОРМИРОВАНИИ ОТЧЕТА БУДЕТ ПРОИЗВЕДЕНА АРХИВАЦИЯ ! ВСЕ ДАННЫЕ ВВЕДЕННЫЕ ЗА ТЕКУЩИЙ ПЕРИОД БУДУТ УДАЛЕНЫ !" ' сообщение.
Btns = vbYesNo + vbCritical + vbDefaultButton2
Result = MsgBox(Msg, Btns, Title, Help, NmbCont)
If Result = vbYes Then
MyString = "Да"

Sheets("Лист2").Range("A1:GQ1992").Copy
Workbooks.Open Filename:="C:\Учет перевозок\АРХИВ.xls"
Application.ScreenUpdating = False
Dim sname As String
sname = CStr(Format(Now, "dd.mm.yy") & " М096ВО")
ActiveWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sname
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Application.ScreenUpdating = True
Sheets("Лист3").Range("A1:GQ1992").Copy
Workbooks.Open Filename:="C:\Учет перевозок\АРХИВ.xls"
Application.ScreenUpdating = False
sname = CStr(Format(Now, "dd.mm.yy") & " М096 оборот")
ActiveWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sname
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Application.ScreenUpdating = True
Sheets("Лист2").Columns("A:GU").Clear
Sheets("Лист3").Columns("A:GU").Clear
Sheets("Лист1").Select
If Result = vbAbort Then
MyString = "Нет"

End If
End If
Sheets("Лист4").Rows("6:60").Clear
End Sub

vladturbo

Если использовать такой код
Происходит копирование и переименование листов, однако не сохраняется высота строк и ширина столбцов

set MySheet = Sheets("Лист2")
Workbooks.Open Filename:="C:\Учет перевозок\АРХИВ.xls"
Application.ScreenUpdating = False
Application.displayalerts = False
MySheet.copy Before:=Worksheets(Worksheets.Count)
ActiveSheet.Name = CStr(Format(Now, "dd.mm.yy") & " М096ВО")

Если использовать такой код аналогично не переименовываются листы

Set MySheet = Sheets("Лист2")
Workbooks.Open Filename:="C:\Учет перевозок\АРХИВ.xls"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sname As String
sname = CStr(Format(Now, "dd.mm.yy") & " М096ВО")
ActiveWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sname
ActiveWorkbook.Save
ActiveWindow.Close
Set MySheet = Sheets("Лист3")
Workbooks.Open Filename:="C:\Учет перевозок\АРХИВ.xls"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sname = CStr(Format(Now, "dd.mm.yy") & " М096 оборот")
ActiveWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sname
ActiveWorkbook.Save
ActiveWindow.Close

Если исключить запрет обновления экрана результат:
1. Все копируется с необходимой высотой строк и шириной столбца.
2. Переименовываются листы в Книге из которой происходит копирование
3. В Книгу, куда листы скопированы, имена листов остаются без изменений


vladturbo

Спасибо заработало. Код такой
Sub Макрос1()
Set MySheet = Sheets("Имя Листа1")
Workbooks.Open Filename:="C:\"Имя файла".xls"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MySheet.Copy Before:=Worksheets(Worksheets.Count)
ActiveSheet.Name = CStr(Format(Now, "dd.mm.yy") & "То что необходимо дописать к имени Листа")
ActiveWorkbook.Save
ActiveWindow.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set MySheet = Sheets("Имя Листа2")
Workbooks.Open Filename:="C:\"Имя файла".xls"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MySheet.Copy Before:=Worksheets(Worksheets.Count)
ActiveSheet.Name = CStr(Format(Now, "dd.mm.yy") & " То что необходимо дописать к имени Листа")
ActiveWorkbook.Save
ActiveWindow.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub