Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Сохранение одного листа как отдельный файл.
 
#1
03.11.2022 09:52:19
Здравствуйте.
Нужен VBA макрос скрипт который бы сохранял активный лист в виде отдельного файла, но вся информация в новом файле должна быть сохранена как текст а в исходном файле должно все остаться как было.

P.S. Находил примерно похожие решения, но они мне не подошли, либо меняли информацию в исходном листе, либо сохраняли формулы, либо сохраняли все листы, либо сохраняли листы с определенным именем(а не активный).
 
 
 
#2
03.11.2022 10:02:00
В,
Код
Sub фывфыв()
    Dim wb As Workbook
    Set wb = ActiveWorkbook
        ActiveSheet.Copy                                                  'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "\" & ActiveSheet.Name & ".xlsx"  'сохраняем файл
End Sub
 
 
 
#3
03.11.2022 10:46:41
Код
Sub CopyPasta()
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Cells.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.SaveAs wb.Path & "\" & ActiveSheet.Name & ".xlsx"
    ActiveWorkbook.Close
End Sub


evgeniygeo, в Вашем варианте не выполняется условие "вся информация в новом файле должна быть сохранена как текст".
 
 
 
#4
03.11.2022 11:27:17
tutochkin, спасибо. Но возникает такая ошибка.


Не знаю из за чего. Попробовал вручную повторить те действия что делает макрос, так-же возникает подобная ошибка.

Но выяснил что если сначала скопировать лист в тот же документ, потом выделить на нем информацию и вставить на тоже место как текст, а потом уже переместить этот лист в новый файл, то такой ошибки не возникает.
Изменено: В - 03.11.2022 11:27:39
 
 
 
#5
03.11.2022 11:56:03
Объединённые ячейки - зло
Ну тогда вот так:
Код
Sub CopyPast()
    Dim sh As Worksheet
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    ActiveSheet.Copy
    For Each sh In ActiveWindow.SelectedSheets
       sh.UsedRange.Value = sh.UsedRange.Value
    Next sh
    ActiveWorkbook.SaveAs wb.Path & "\" & ActiveSheet.Name & ".xlsx"
    ActiveWorkbook.Close
End Sub
 
 
 
#6
03.11.2022 12:24:20
tutochkin, этот вариант копирует ошибку "#ССЫЛКА!" в виде текста, в ячейки где были формулы.
 
 
 
#7
03.11.2022 12:25:26
Цитата
tutochkin написал:
For Each sh In ActiveWindow.SelectedSheets       sh.UsedRange.Value = sh.UsedRange.Value    Next sh
И зачем это для 1 листа?
 
 
 
#8
03.11.2022 12:44:56
В, Давайте файл пример.
 
 
 
#9
03.11.2022 13:22:47
tutochkin, определил что ваш макрос некорректно работает из за использования функции "ДВССЫЛ", но без нее к сожалению никак.
Вот создал пример с похожей структурой.
 
 
 
#10
03.11.2022 13:24:24
Интересно, как код Тутохина может не работать, не понимаю. Но, можно и по другому, сначала все заменить на листе на значения, потом удалить остальные листы и получившееся сохранить под новым именем.
Код
Sub CopyPage()
    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value  ' заменяем все формулы на значения
    Application.DisplayAlerts = False
    For Each s In Sheets
        If Not s Is ActiveSheet Then s.Visible = xlSheetVisible: s.Delete ' удаляем все листы кроме активного
    Next
    Application.DisplayAlerts = True
    ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"  'сохраняем файл
End Sub
Только,тут сюрприз можно словить  - источник, при этом, закрыт без сохранения. А, вот нужно ли сохранять источник до операции,  об этом не известно..
Изменено: Sergey Stoyanov - 03.11.2022 13:25:10
 
 
 
#11
03.11.2022 13:31:26
В, а так?
Код
Option Explicit

Sub SaveSheets()
    Dim s           As Object
    Dim Wsh         As Worksheet
    Dim iPath       As String
    Dim i           As Long

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With

    iPath = ThisWorkbook.Path
    Set Wsh = ActiveSheet
    Wsh.Copy

    ' Save with Worksheet name
    ActiveWorkbook.SaveAs iPath & "\" & Wsh.Name & ".xlsx"

    ' Save with Value
    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

    ' Delete All Data Validation
    ActiveSheet.Cells.Validation.Delete

    ' Delete All Comments
    ActiveSheet.Cells.ClearComments

    ' Delete All Link to another Workbook
    Dim WorkbookLinks As Variant
    WorkbookLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)

    If IsArray(WorkbookLinks) Then

        For i = LBound(WorkbookLinks) To UBound(WorkbookLinks)
            ActiveWorkbook.BreakLink _
                    Name:=WorkbookLinks(i), _
                    Type:=xlLinkTypeExcelLinks
        Next i

    Else
    End If

    For Each s In ActiveSheet.Shapes

        ' Delete All Form Controls, ActiveX Controls include All Pictures
        s.Delete
    Next s

    ActiveWorkbook.Close SaveChanges:=True

    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub


При активном листе.
Изменено: MikeVol - 03.11.2022 13:36:08 (ошибка, исправил)
 
 
 
#12
03.11.2022 13:49:55
MikeVol, Sergey Stoyanov, В,
Немного сам изменил макросы получилось так. Работает.
Код
Sub CopyTest2()
    Dim Path As String
    Path = ActiveWorkbook.Path
    Dim Name As String
    Name = ActiveSheet.Name

    ActiveSheet.Copy Before:=Sheets(1)
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A1").Select
    ActiveSheet.Select
    ActiveSheet.Move
    ActiveWorkbook.SaveAs Path & "\" & ActiveSheet.Name & ".xlsx"
    ActiveWindow.Close
    Sheets(Name).Select
End Sub
 
 
 
#13
03.11.2022 13:58:37
В, https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=153209&TITLE_SEO=153209-sokhranenie-odnogo-lista-kak-otdelnyy-fayl.&MID=1222684#message1222684
 
 
 
#14
03.11.2022 14:00:21
MikeVol, почему то не сохраняет файл или сохраняет неизвестно куда.
 
 
 
#15
03.11.2022 14:39:02
Цитата
написал:
MikeVol , почему то не сохраняет файл или сохраняет неизвестно куда.
А зачем что-то еще использовать, нормальная же у вас идея реализована - дублирует лист в ту же  книгу при этом, формула двойной ссылки ссылается куда надо, а не в пустоту. Затем заменяет на значения, потом перемещает его в новую книгу и сохраняет.  Ну, лишнего в рекордере позаписано, это не важно. Можно почистить. Правда, напрочь не понимаю, зачем в примере двойная ссылка, там индекс прекрасно работает. Даже просто приравнивать к соответствующему листу можно... Или вы лист с которого данные подтягиваются, где то из выпадающего списка выбираете? Ну, тогда и название для сохранения имеет смысл оттуда же брать.    
 
 
 
#16
03.11.2022 14:54:02
Sergey Stoyanov,
"А зачем что-то еще использовать, нормальная же у вас идея реализована"
ну раз попросили проверить, почему бы и нет.
Цитата
написал:
1.2022 13:58:37


В ,  https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=153209&a...

"Правда, напрочь не понимаю, зачем в примере двойная ссылка, там индекс прекрасно работает. "
Ну это просто пример, накидал первое что пришло в голову. В реальном файле без "ДВССЫЛ" не получается.
 
 
 
#17
03.11.2022 15:09:20
Код
Sub CopyTest3()
    Dim sPath As String, sName As String
    sPath = ActiveWorkbook.Path
    sName = ActiveSheet.Name
    ActiveSheet.Copy Before:=Sheets(1)
    Sheets(1).UsedRange.Value = Sheets(1).UsedRange.Value
    Sheets(1).Move
    ActiveSheet.Name = sName
    ActiveWorkbook.SaveAs sPath & "\" & sName & ".xlsx", 51
    ActiveWorkbook.Close
End Sub
 
 
 
#18
03.11.2022 15:12:16
RAN, спасибо
 
 
 
#19
03.11.2022 16:28:41
Чего то подумалось. Можно же через массив значения передать. Без создания листа в исходной книге
Код
Sub CopyPast()
    Dim a() As Variant
    Dim sName As String, sPath As String, sAddr As String
    sPath = ActiveWorkbook.Path
    sName = ActiveSheet.Name
    sAddr = ActiveSheet.UsedRange.Address
    a = ActiveSheet.UsedRange.Value
    ActiveSheet.Copy
    Range(sAddr) = a
    ActiveWorkbook.SaveAs sPath & "\" & sName & ".xlsx"
    ActiveWorkbook.Close
End Sub
 
 
 
Страницы: 1
Наверх