Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование отфильтрованного диапазона в новый лист новой книги
 
#1
01.03.2017 09:52:11
доброго дня всем !
макрос копирует данные таблицы из исходной таблицы - далее создается папка в директории файла и новый файл куда копируются значения и формат исходной таблицы
только незадача - просто значения копирутся нормально, а вот отфильтрованные значения в исходной таблице не копируются к сожалению
Что поправить в макросе ?
Код
Sub Copy()
Application.ScreenUpdating = False 'чтоб не моргало выключаем скрин
Application.DisplayAlerts = False

Call Создать_папку_ДАТА 'создаем папку ДАТА в корне файла

Dim strFileName As String 'имя файла который создаем Дата_27.02.2017_20.35.xls
strFileName = ThisWorkbook.Path & "\ДАТА\Дата_" & Format(Date, "dd.mm.yyyy") & "_" & Format(Time, "HH.mm") & ".xls"

Call КопированиеДанных 'копируем таблицу с отфильтрованными значениями
ActiveWorkbook.SaveAs strFileName

Application.CutCopyMode = False

Application.DisplayAlerts = True
Application.ScreenUpdating = True 'включаем скрин
End Sub

Sub КопированиеДанных()
    Workbooks.Add xlWBATWorksheet
    ActiveSheet.Name = "Результаты_копирования" 'обзываем лист новой книги
    ThisWorkbook.ActiveSheet.Range("A1:G500").Copy 'диапазон копирования
    ActiveSheet.[A1].PasteSpecial
    ActiveSheet.[A1].PasteSpecial xlPasteValues 'копируем значения
    ActiveSheet.[A1].PasteSpecial xlPasteFormats 'копируем формат
    ActiveSheet.[A1].PasteSpecial Paste:=xlPasteColumnWidths 'корпируем ширину столбцов
    ActiveSheet.Rows("1:500").EntireRow.AutoFit 'выравнивание высоты строки
End Sub

Sub Создать_папку_ДАТА()
    On Error Resume Next
    Const folder$ = "ДАТА" ' название основной папки
    MkDir ThisWorkbook.Path & "\" & folder$ ' создаём папку в директории, если её ещё нет
 End Sub
 
 
 
#2
01.03.2017 10:57:53
Копируйте только видимые - specialcells(12).
Я сам - дурнее всякого примера! ...
 
 
 
#3
01.03.2017 11:03:20
только бы еще знать как  specialcells(12)  в код поставить
 
 
 
#4
01.03.2017 12:01:21
пробую так  не получается

Код
Sub КопированиеДанных()
    Workbooks.Add xlWBATWorksheet
    ActiveSheet.Name = "Результаты_копирования" 'обзываем лист новой книги

Workbooks("Книга1").Worksheets("Данные").Range("A1:G500").SpecialCells(12).Copy Sheets("Результаты_копирования").[A1]

    ThisWorkbook.ActiveSheet.Range("A1:G500").Copy 'диапазон копирования
    ActiveSheet.[A1].PasteSpecial xlPasteValues 'копируем значения
    ActiveSheet.[A1].PasteSpecial xlPasteFormats 'копируем формат
    ActiveSheet.[A1].PasteSpecial Paste:=xlPasteColumnWidths 'корпируем ширину столбцов
    ActiveSheet.Rows("1:500").EntireRow.AutoFit 'выравнивание высоты строки
End Sub
 
 
 
#5
01.03.2017 12:05:39
Если вы скопировали видимые, то зачем тогда строка
Код
ThisWorkbook.ActiveSheet.Range("A1:G500").Copy 'диапазон копирования
 
 
 
#6
01.03.2017 13:32:51
Убрал сорри но все равно ошибка идет на строке
Workbooks("Книга1").Worksheets("Данные").Range("A1:G500").SpecialCells(12).Copy Sheets("Результаты_копирования").[A1]

Код
Sub КопированиеДанных()
    Workbooks.Add xlWBATWorksheet
    ActiveSheet.Name = "Результаты_копирования" 'обзываем лист новой книги
 
Workbooks("Книга1").Worksheets("Данные").Range("A1:G500").SpecialCells(12).Copy Sheets("Результаты_копирования").[A1]
 
    ActiveSheet.[A1].PasteSpecial xlPasteValues 'копируем значения
    ActiveSheet.[A1].PasteSpecial xlPasteFormats 'копируем формат
    ActiveSheet.[A1].PasteSpecial Paste:=xlPasteColumnWidths 'корпируем ширину столбцов
    ActiveSheet.Rows("1:500").EntireRow.AutoFit 'выравнивание высоты строки
End Sub
 
 
 
#7
01.03.2017 14:21:29
При копировании сначала вставляем ширину столбцов, затем все остальное
Код
    ThisWorkbook.ActiveSheet.Range("A1:G500").SpecialCells(12).Copy
    'ThisWorkbook.ActiveSheet.Range("A1:G500").Copy 'диапазон копирования
    'ActiveSheet.[A1].PasteSpecial
    ActiveSheet.[A1].PasteSpecial Paste:=xlPasteColumnWidths 'корпируем ширину столбцов
    ActiveSheet.[A1].PasteSpecial xlPasteValues 'копируем значения
    ActiveSheet.[A1].PasteSpecial xlPasteFormats 'копируем формат
    ActiveSheet.Rows("1:500").EntireRow.AutoFit 'выравнивание высоты строки
 
 
 
#8
01.03.2017 14:26:59
Kuzmich спасибо за совет - все пошло как надо !
 
 
 
Страницы: 1
Наверх