Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос по сохранению листа книги
 
#1
19.06.2024 17:38:15
Всем добрый день. Нужна ваша помощь. Нужно написать макрос, чтобы лист книги сохранялся в определенной папке с именем определенной ячейки (х1), в которой нужно убрать запрещенные символы ("") ,без формул и объектов с листа.
Я в них совершенно не шарю, однако попыталась и собрала вот такой макрос. Но при открытии созданного документа периодически вылазит ошибка в части содержимого в книге. далее :
Удаленные записи: Именованный диапазон из части /xl/workbook.xml (Книга)
Удаленные записи: Формула из части /xl/worksheets/sheet1.xml
Удаленные записи: Общая формула из части /xl/worksheets/sheet1.xml
Удаленные записи: Формула из части /xl/calcChain.xml (Свойства вычислений)
Может кто поможет сделать его работу корректной
Код
Sub Сохранить()

  UserResponse = MsgBox("Хотите сохранить документ?", vbYesNo)
    If UserResponse = vbYes Then

Range("X2").Select
    Selection.Copy
    Range("X1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("X1").Select
    ActiveCell.Replace What:="""", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Find(What:="""", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
        Columns("O:X").Select
    Selection.EntireColumn.Hidden = True
    ActiveSheet.Range("$O$20:$O$41").AutoFilter Field:=1, Criteria1:="=1", _
        Operator:=xlOr, Criteria2:="="
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
Dim wb As Workbook, sName As String, sPath As String
Application.DisplayAlerts = False
sPath = "C:\Users\User\Desktop\Текущие договора\"
sName = Cells(1, 24).Value
Set wb = ThisWorkbook
wb.ActiveSheet.Copy
Set wbCopySheet = ActiveWorkbook
Dim oSh As Object
For Each oSh In ActiveSheet.Shapes
   oSh.Delete
Next
 Columns("N:Y").Select
    Selection.EntireColumn.Hidden = False
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Range("A1:X18").Select
    Selection.Copy
    ActiveWindow.ScrollColumn = 20
    ActiveWindow.ScrollColumn = 19
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 1
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B1").Select

wbCopySheet.SaveAs Filename:=sPath & sName & ".xlsx", FileFormat:=51
wbCopySheet.Close
Application.DisplayAlerts = True
MsgBox ("Файл сохранен: " & Range("x1").Value)
 Else
 MsgBox "Документ не сохранен!"
  End If

End Sub
 
 
 
#2
19.06.2024 22:39:08
Здравствуйте.
Код
Sub ExportSheet()
    Dim userResponse As Integer, wbPath As String
    userResponse = MsgBox("Хотите сохранить документ?", vbYesNo)
    If userResponse = vbNo Then Exit Sub
    wbPath = Environ("USERPROFILE") & "\Desktop\" 'Your folder
    ActiveSheet.Copy
    ActiveSheet.Shapes.SelectAll
    Selection.Delete ' Remove all shapes on a sheet
    ActiveSheet.UsedRange.Formula = ActiveSheet.UsedRange.Value 'Convert formulas to values
    ActiveWorkbook.SaveAs Filename:=wbPath & ReplaceSymbols(Range("X1")) & ".xlsx", FileFormat:=xlWorkbookDefault
    ActiveWorkbook.Close SaveChanges:=True
End Sub
Function ReplaceSymbols(ByVal txt As String) As String
    Dim strSymbols As String, i%
    strSymbols = "~!@/\#$%^&*=|`"""
    For i = 1 To Len(strSymbols)
        txt = Replace(txt, Mid(strSymbols, i, 1), "_")
    Next
    ReplaceSymbols = txt
End Function

Доделывать будете сами, файла примера нету, что там искать, какой фильтр и какие там еще операции - это известно только Вам.
Изменено: DANIKOLA - 20.06.2024 17:18:48
 
 
 
#3
20.06.2024 08:43:59
DANIKOLA,  прикрепляю файл документа.
Сортировка идет по фильтру "все, кроме нулей", чтобы убрать пустые строчки из заявки.
Копирование из х2 в х1 как текст и далее замена там кавычек. Так же в итоговом документе нужно скрыть столбцы О-Х
По вашему коду файл создает, однако его невозможно открыть  
 
 
 
#4
20.06.2024 09:20:40
Цитата
hury написал:
По вашему коду файл создает, однако его невозможно открыть
У меня все нормально открывается.
Может быть кто-нибудь код получше напишет или может проблема на Вашем ПК, ведь первый код, не смотря на всю его кривизну, должен работать без проблем.
 
 
 
#5
20.06.2024 10:09:07
hury, добрый день. Добавьте расширения файла в название сохраняемого в коде от  DANIKOLA
Код
ActiveWorkbook.SaveAs Filename:=wbPath & ReplaceSymbols(Range("X1")) & ".xlsx"
 
 
 
#6
20.06.2024 11:40:17
Alex, спасибо. Помогло :D  
 
 
 
#7
20.06.2024 17:13:09
Цитата
Alex написал:
Добавьте расширения файла
Интересно почему у hury  не работает, проверял на Win10/Office 2010 и 2021 все отрывается. При написании кода была мысль поставить расширение, как в сообщении №1, но как-то подумал, что когда мы сохраняем файл Excel вручную, мы ведь не указываем расширение, вот и решил попробовать без расширения, проверил оба варианта, все работает ок...
UPD:
Цитата
Alex написал:
У меня тоже не сработал макрос win10/365
Понятно, буду писать с расширением.
_______
hury, можно избавиться от этих строк кода:
Код
ActiveWindow.ScrollColumn = ...

они, можно сказать, мусорные, только раздувают код.
В VBA можно управлять объектами не выделяя их, т.е., можно поубирать все Select(ы) и Selection(ы) или б0льшую их часть.
Например показать скрытые столбцы:
Код
Columns("N:Y").EntireColumn.Hidden = False

Также с Range("X2").Select, можно сразу:
Код
Range("X2").Copy' И дальше аналогично без Select и Selection
Range("X2").PasteSpecial Paste:=xlPasteValues '...

Ну и докопируете недостающие строки кода в правильном порядке.

P.S. Ну, а делать все вместо Вас лень, попробуйте сами, а если что не получится, пишите сюда же...
Изменено: DANIKOLA - 20.06.2024 17:38:16 (Добавил ответ Alex)
 
 
 
#8
20.06.2024 17:28:05
DANIKOLA,  здравствуйте. У меня тоже не сработал макрос win10/365, сохранил без расширения. Поэтому и предложил добавить в код расширение явно
 
 
 
Страницы: 1
Читают тему
Наверх