Страницы: 1
RSS
Создание нового файла Excel и копирования в него определенных ячеек, макрос
 
Можно ли сделать кнопку или как её сделать, чтобы при нажатии кнопки, ранее заданные ячейки, копировались в новый файл Excel имя которого дата и время нажатия этой кнопки?
например нужно скопировать диапозон ячеек 30R x 7C (только значения без формул) в другой файл Excel с названием времени и даты в момент нажатия на кнопку.
 
Код
Sub Macro1()

    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    
    Dim ConstFilePath As String
    Dim ConstFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    
    Application.ReferenceStyle = xlA1
 
    Set Source = Nothing
    On Error Resume Next
    Set Source = Sheets("Sheet1").Range("A1:P9000").SpecialCells(xlCellTypeVisible) 'этот интервал значений с листа будет сохранен
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With

    ConstFilePath = "S:\ANYFOLDER\"  'пусть сохранения
    ConstFileName = ThisWorkbook.Sheets("sheet1").Range("A1").Value & " - " & Format(Date, "dd.mm") & "." & ".xlsm"  'имя файла. Значение с ячейки А1 + дата.

FileExtStr = ".xlsx": FileFormatNum = 52
  
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
  
    With Dest
        .SaveAs ConstFilePath & ConstFileName & FileExtStr
        On Error Resume Next
    End With
     
End Sub
 
Примерно такой код. Остается только имя файла заменить на нужное Вам, там можно и до минут и секунд прописать. Ну и кнопочку нарисовать да и макрос ей назначить. Думаю додумаете
 
Цитата
ShtrihKot написал:
Можно ли сделать кнопку или как её сделать,
Разработчик>Элементы управления>Вставить, далее выбираете на свое усмотрение вид кнопки либо Элемент управления формы либо ActiveX
Цитата
ShtrihKot написал:
ранее заданные ячейки
Каким образом ранее заданные? Выделены? Каким образом выделены в несколько диапазонов или в один сплошной?
"Все гениальное просто, а все простое гениально!!!"
 
Для начала необходимо включить вкладку "Разработчик", там можете нажать запись макроса и сделать все действия которые необходимы. Потом посмотреть полученный код в записанном макросе. Если что то нужно откорректировать по аналогии.  
 
Paul Zealand,Перепробовал все диапазоны и пути сохранения, всё равно вылетает "The source is not a range or the sheet is protected, please correct and try again."
 
ShtrihKot, в моем примере интервал от А1 до Р9000. Попробуйте свой диапозон. Ну и видимо ячейки у Вас защищенные на листе, попробуйсе снять защиту. Проверьте все пути сохранений в коде. Имена страниц совпадают ли и т.д.
 
Set Source = Sheets("Sheet1").Range("A42:G72").SpecialCells(xlCellTypeVisible) 'этот интервал значений с листа будет сохранен
ConstFilePath = "D:\SystemData\Desktop\"  'пусть сохранения
   ConstFileName = ThisWorkbook.Sheets("sheet1").Range("B42").Value & " - " & Format(Date, "dd.mm") & "." & ".xlsm"  'имя файла. Значение с ячейки B42 + дата.

Проверил в "рецензировании" блокировок нет...
 
Nordheim, Допустим есть 3 таблицы, в 2 из них идёт подсчет расходников в третьей сумма с двух, нужно чтоб третья таблица при нажатии кнопки копировалась в отдельный файл


Товарищ Paul Zealand предоставил подходящий макрос, понять не могу почему не срабатывает....
Изменено: ShtrihKot - 04.12.2018 11:08:23
 
ShtrihKot, если Вы не планируете в рамках Вашей таблицы использовать автофильтр, то можете попробовать убрать вот эту часть .SpecialCells(xlCellTypeVisible).
Что-то у Вас с переменной Source не так. Или на самом листе в этом интервале есть объединенные ячеки. Или что-то такое. Попробуйте с другим диапозонов, максимально минимальным A1:A2, например, просто чтобы понять работает ли с другим диапозоном.
 
Цитата
ShtrihKot написал:
Товарищ  Paul Zealand  предоставил подходящий макрос
Перемудрил товарищ Paul Zealand ) Можно короче:
Код
Sub Макрос1()
    Workbooks.Add
    Range("C7:R30").Value = ThisWorkbook.Sheets("Лист1").Range("C7:R30").Value
    ActiveWorkbook.SaveAs Filename:="D:\Downloads\" & Replace(Now, ":", "_") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
Поправьте адреса диапазонов, если нужны другие.
 
Юрий М, Вы же помните, я не волшебник, я еще только учусь )))
 
Paul Zealand, Путь у Вас для обучения выбран тернистый и сложный   ;)
"Все гениальное просто, а все простое гениально!!!"
 
Я помню )
 
Nordheim, у каждого свой путь ))
 
Цитата
Paul Zealand написал:
у каждого свой путь ))
Согласен, но Ваш будет долгим, и не сразу понятным, сравните код Ваш и от Юрий М, чувствуете разницу, код из трех строк более удобен к прочтению чем из полусотни, я как бы за оптимизацию  :D. Вам удачи в обучении, но старайтесь не усложнять, то , что можно написать просто.
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, я с Вами согласен. Вот в компании таких мастодонтов может и вырасту ))
 
Цитата
DopplerEffect написал:
Для начала необходимо включить вкладку "Разработчик", там можете нажать запись макроса
Есть путь короче: слева внизу, рядом с надписью "Готово" есть эта самая заветная кнопочка ))
 
Всем спасибо, проблема была в названии листа "Лист1" а не "Sheet1" и я не обратил на это внимания.
Paul Zealand спасибо, ваш макрос копирует даже формат ячеек с выравниванием, размером и отсутствием формул. Просто гениально!
Страницы: 1
Наверх