Копирование активного листа без формул и вып.списков

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование активного листа без формул и вып.списков (Макросы Sub)

Digital

Дата: Вторник, 24.12.2013, 19:30 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 225

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Доброго времени суток уважаемые форумчане,
У меня имеется файл под названием "форма", макрос выполняет все что мне нужно, копирует активный лист но со всеми формулами и выпадающими списками. Хотелось бы копирование только значений без формул и выпадающих списков. Где то макрос не выполняется и оставляет все формулы и вып.списки в новой скопированной книге. Помогите подправить тело макроса?

[vba]

Код

Sub Сохранение()
On Error Resume Next
' название подпапки, в которую по-умолчанию будет предложено сохранить файл
Const REPORTS_FOLDER = "C:Users\Aman\Desktop\Games"
' ?создаём папку для файла, если её ещё нет
MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
' выбираем стартовую папку
ChDrive Left(ThisWorkbook.Path, 1): ChDir "C:\Users\Aman\Desktop\Games"

' вывод диалогового окна для запроса имени сохраняемого файла
Filename = Application.GetSaveAsFilename("PO-13-.xlsx", "Excel (*.xlsx),", , _
"Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub

' копируем активный лист (при этом создаётся новая книга)
Err.Clear: ActiveSheet.Copy: DoEvents
If Err Then Exit Sub ' произошла какая-то ошибка при попытке копирования листа

' убеждаемся, что активной книгой является копия листа
If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
ActiveWorkbook.ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook

' теперь убираем формулы и выпадающие списки с копии листа
For Each c In Selection
c.FormulaR1C1 = c.Value
Next c

' закрываем сохранённый файл
' (удалите следующую строку, если закрывать созданный файл не требуется)
ActiveWorkbook.Close False
End If
End Sub

[/vba]

Код

[/vba]Digital

К сообщению приложен файл: 3302489.xlsx (91.6 Kb)

Ответить

СообщениеДоброго времени суток уважаемые форумчане,
У меня имеется файл под названием "форма", макрос выполняет все что мне нужно, копирует активный лист но со всеми формулами и выпадающими списками. Хотелось бы копирование только значений без формул и выпадающих списков. Где то макрос не выполняется и оставляет все формулы и вып.списки в новой скопированной книге. Помогите подправить тело макроса?

[vba]

Код

[/vba]

Автор - Digital
Дата добавления - 24.12.2013 в 19:30

KuklP

Дата: Вторник, 24.12.2013, 19:54 | Сообщение № 2

Группа: Проверенные

Ранг: Старожил

Сообщений: 2369

Репутация: 486 ±

Замечаний: 0% ±

2003-2010

[vba]

Код

with ActiveWorkbook.ActiveSheet
.DrawingObjects.Delete
.usedrange.value=.usedrange.value
.parent.SaveAs Filename, xlOpenXMLWorkbook
end with

[/vba]
а вот это:
[vba]

Код

' теперь убираем формулы и выпадающие списки с копии листа
For Each c In Selection
c.FormulaR1C1 = c.Value
Next c

[/vba]удалите. И оформляйте коды тегами, знак # над окном ввода.

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Сообщение отредактировал KuklP - Вторник, 24.12.2013, 19:56

Ответить

Digital

Дата: Вторник, 24.12.2013, 22:03 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 225

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

KuklP спасибо за участие и подсказку,
Переделал макрос, к сожалению не срабатывает.

[vba]

Код

Sub Сохранение()
On Error Resume Next
' название подпапки, в которую по-умолчанию будет предложено сохранить файл
Const REPORTS_FOLDER = "C:Users\Aman\Desktop\Games"
' ?создаём папку для файла, если её ещё нет
MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
' выбираем стартовую папку
ChDrive Left(ThisWorkbook.Path, 1): ChDir "C:\Users\Aman\Desktop\Games"

' вывод диалогового окна для запроса имени сохраняемого файла
Filename = Application.GetSaveAsFilename("PO-13-.xlsx", "Excel (*.xlsx),", , _
"Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub

' копируем активный лист (при этом создаётся новая книга)
Err.Clear: ActiveSheet.Copy: DoEvents
If Err Then Exit Sub ' произошла какая-то ошибка при попытке копирования листа

' убеждаемся, что активной книгой является копия листа
If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
With ActiveWorkbook.ActiveSheet.DrawingObjects.Delete
UsedRange.Value = .UsedRange.Value
Parent.SaveAs Filename, xlOpenXMLWorkbook

' закрываем сохранённый файл
' (удалите следующую строку, если закрывать созданный файл не требуется)
ActiveWorkbook.Close False
End If
End Sub

[/vba]

Ответить

СообщениеKuklP спасибо за участие и подсказку,
Переделал макрос, к сожалению не срабатывает.

[vba]

Код

Sub Сохранение()
On Error Resume Next
' название подпапки, в которую по-умолчанию будет предложено сохранить файл
Const REPORTS_FOLDER = "C:Users\Aman\Desktop\Games"
' ?создаём папку для файла, если её ещё нет
MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
' выбираем стартовую папку
ChDrive Left(ThisWorkbook.Path, 1): ChDir "C:\Users\Aman\Desktop\Games"

' вывод диалогового окна для запроса имени сохраняемого файла
Filename = Application.GetSaveAsFilename("PO-13-.xlsx", "Excel (*.xlsx),", , _
"Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub

' копируем активный лист (при этом создаётся новая книга)
Err.Clear: ActiveSheet.Copy: DoEvents
If Err Then Exit Sub ' произошла какая-то ошибка при попытке копирования листа

' убеждаемся, что активной книгой является копия листа
If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
With ActiveWorkbook.ActiveSheet.DrawingObjects.Delete
UsedRange.Value = .UsedRange.Value
Parent.SaveAs Filename, xlOpenXMLWorkbook

' закрываем сохранённый файл
' (удалите следующую строку, если закрывать созданный файл не требуется)
ActiveWorkbook.Close False
End If
End Sub

[/vba]

Автор - Digital
Дата добавления - 24.12.2013 в 22:03

KuklP

Дата: Вторник, 24.12.2013, 22:11 | Сообщение № 4

Группа: Проверенные

Ранг: Старожил

Сообщений: 2369

Репутация: 486 ±

Замечаний: 0% ±

2003-2010

Дык, ахинея потому что. что по-Вашему получится в результате:
[vba]

Код

    Const REPORTS_FOLDER = "C:Users\Aman\Desktop\Games"
     ' ?создаём папку для файла, если её ещё нет
     MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER

[/vba]
?
Попробуйте выполнить:
[vba]

Код

    Const REPORTS_FOLDER = "C:Users\Aman\Desktop\Games"
     ' ?создаём папку для файла, если её ещё нет
     msgbox ThisWorkbook.Path & "\" & REPORTS_FOLDER

[/vba] и посмотрите, какой путь Вы пытаетесь втюхать.

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

KuklP

Дата: Вторник, 24.12.2013, 22:19 | Сообщение № 5

Группа: Проверенные

Ранг: Старожил

Сообщений: 2369

Репутация: 486 ±

Замечаний: 0% ±

2003-2010

Цитата Digital, 24.12.2013 в 22:03, в сообщении № 3

Переделал макрос, к сожалению не срабатывает.

Надо внимательно читать, что советуют. Куда подевались точки? Куда делось end with? Должно быть так:
[vba]

Код

    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
         With ActiveWorkbook.ActiveSheet
             .DrawingObjects.Delete
             .UsedRange.Value = .UsedRange.Value
             .Parent.SaveAs Filename, xlOpenXMLWorkbook
         End With
         ' закрываем сохранённый файл
         ' (удалите следующую строку, если закрывать созданный файл не требуется)
         ActiveWorkbook.Close False
     End If

[/vba]

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

Digital

Дата: Вторник, 24.12.2013, 22:24 | Сообщение № 6

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 225

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

KuklP,
Изменил значение на диск С, но формулы и вып.списки не исчезли. Плиз может что-то еще посоветуте?

[vba]

Код

Sub Сохранение()
On Error Resume Next
' название подпапки, в которую по-умолчанию будет предложено сохранить файл
Const REPORTS_FOLDER = "C:Users\Aman\Desktop\Games"
' ?создаём папку для файла, если её ещё нет
MkDir ThisWorkbook.Path & "C:"
' выбираем стартовую папку
ChDrive Left(ThisWorkbook.Path, 1): ChDir "C:\Users\Aman\Desktop\Games"

' вывод диалогового окна для запроса имени сохраняемого файла
Filename = Application.GetSaveAsFilename("PO-13-.xlsx", "Excel (*.xlsx),", , _
"Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub

' копируем активный лист (при этом создаётся новая книга)
Err.Clear: ActiveSheet.Copy: DoEvents
If Err Then Exit Sub ' произошла какая-то ошибка при попытке копирования листа

' убеждаемся, что активной книгой является копия листа
If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
ActiveWorkbook.ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook

' теперь убираем формулы и выпадающие списки с копии листа
For Each c In Selection
c.FormulaR1C1 = c.Value
Next c

' закрываем сохранённый файл
' (удалите следующую строку, если закрывать созданный файл не требуется)
ActiveWorkbook.Close False
End If
End Sub

[/vba]

KuklP,
Изменил значение на диск С, но формулы и вып.списки не исчезли. Плиз может что-то еще посоветуте?

[vba]

Код

Sub Сохранение()
On Error Resume Next
' название подпапки, в которую по-умолчанию будет предложено сохранить файл
Const REPORTS_FOLDER = "C:Users\Aman\Desktop\Games"
' ?создаём папку для файла, если её ещё нет
MkDir ThisWorkbook.Path & "C:"
' выбираем стартовую папку
ChDrive Left(ThisWorkbook.Path, 1): ChDir "C:\Users\Aman\Desktop\Games"

' вывод диалогового окна для запроса имени сохраняемого файла
Filename = Application.GetSaveAsFilename("PO-13-.xlsx", "Excel (*.xlsx),", , _
"Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub

' копируем активный лист (при этом создаётся новая книга)
Err.Clear: ActiveSheet.Copy: DoEvents
If Err Then Exit Sub ' произошла какая-то ошибка при попытке копирования листа

' убеждаемся, что активной книгой является копия листа
If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
ActiveWorkbook.ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook

' теперь убираем формулы и выпадающие списки с копии листа
For Each c In Selection
c.FormulaR1C1 = c.Value
Next c

' закрываем сохранённый файл
' (удалите следующую строку, если закрывать созданный файл не требуется)
ActiveWorkbook.Close False
End If
End Sub

[/vba]Digital

Сообщение отредактировал Digital - Вторник, 24.12.2013, 22:27

Ответить

СообщениеKuklP,
Изменил значение на диск С, но формулы и вып.списки не исчезли. Плиз может что-то еще посоветуте?

[vba]

Код

Sub Сохранение()
On Error Resume Next
' название подпапки, в которую по-умолчанию будет предложено сохранить файл
Const REPORTS_FOLDER = "C:Users\Aman\Desktop\Games"
' ?создаём папку для файла, если её ещё нет
MkDir ThisWorkbook.Path & "C:"
' выбираем стартовую папку
ChDrive Left(ThisWorkbook.Path, 1): ChDir "C:\Users\Aman\Desktop\Games"

' вывод диалогового окна для запроса имени сохраняемого файла
Filename = Application.GetSaveAsFilename("PO-13-.xlsx", "Excel (*.xlsx),", , _
"Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub

' копируем активный лист (при этом создаётся новая книга)
Err.Clear: ActiveSheet.Copy: DoEvents
If Err Then Exit Sub ' произошла какая-то ошибка при попытке копирования листа

' убеждаемся, что активной книгой является копия листа
If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
ActiveWorkbook.ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook

' теперь убираем формулы и выпадающие списки с копии листа
For Each c In Selection
c.FormulaR1C1 = c.Value
Next c

' закрываем сохранённый файл
' (удалите следующую строку, если закрывать созданный файл не требуется)
ActiveWorkbook.Close False
End If
End Sub

[/vba]

Автор - Digital
Дата добавления - 24.12.2013 в 22:24

Digital

Дата: Вторник, 24.12.2013, 22:38 | Сообщение № 7

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 225

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

KuklP,
Исправил макрос в соответствии с вашими замечаниями. Формулы уже не копируются за это вам спасибо, но к сожалению вып.списки все еще остаются в сохраняемом листе :'(