Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование не пустых значений и вставка в другую табицу, Необходимо из 1 таблицы скопировать только не пустые и вставить их в другую таблицы
 
#1
21.07.2019 14:05:25
Добрый день Уважаемые знатоки, долго искал подходящий ответ на вопрос на форуме, но не нашел в силу того что не очень силен в макросах, но стараюсь разобраться.
Сейчас стоит следующая задача, необходимо из таблицы А2:H15 (лист: Таблица исходная) скопировать не пустые значения и потом добавить их как новые строки ниже в "Умную таблицу" (ТаблицаЗначений) на листе: Таблица для вставки. Вставлять данные необходимо не как формулы а как простое значение ячейки.

Как копировать просто значение по сроке и потом переносить их в умную таблицу я сделал, но вот задача в том что в таблице А2:H15 (лист: Таблица исходная)  может быть как 1 так и 5 и 12 и 20 значений.
В файл примера добавил небольшой макрос который сейчас у меня работает, но только по первой строке, а как сделать его так чтобы можно было копировать не пустые значения и сразу вставлять их все по нажатию кнопки я не  знаю.

Помогите пожалуйста решить эту задачу.
Ниже макрос который присутствует в файле (для наглядности).
Код
Sub Копирование_первой_строки()
Dim whishodniy As Worksheet, whBD As Worksheet, lobjDB As ListObject, lngI As Long
    Application.ScreenUpdating = False 'отключаем обновление экрана
    Set whishodniy = Worksheets("Таблица исходная"): Set whBD = Worksheets("Таблица для вставки"): Set lobjDB = whBD.ListObjects("ТаблицаЗначений")
    lobjDB.ListRows.Add 'добавляем в "умную" таблицу строку
    lngI = lobjDB.ListRows.Count 'считаем количество строк с данными в "умной" таблице
    'копируем и переносим как спец.вставка значений по каждой ячейке таблицы из формы с листа таблица исходная в умную таблицу листа для вставки
    whishodniy.[A2].Copy: lobjDB.DataBodyRange(lngI, 1).PasteSpecial Paste:=xlPasteValues
    whishodniy.[B2].Copy: lobjDB.DataBodyRange(lngI, 2).PasteSpecial Paste:=xlPasteValues
    whishodniy.[C2].Copy: lobjDB.DataBodyRange(lngI, 3).PasteSpecial Paste:=xlPasteValues
    whishodniy.[D2].Copy: lobjDB.DataBodyRange(lngI, 4).PasteSpecial Paste:=xlPasteValues
    whishodniy.[E2].Copy: lobjDB.DataBodyRange(lngI, 5).PasteSpecial Paste:=xlPasteValues
    whishodniy.[F2].Copy: lobjDB.DataBodyRange(lngI, 6).PasteSpecial Paste:=xlPasteValues
    whishodniy.[G2].Copy: lobjDB.DataBodyRange(lngI, 7).PasteSpecial Paste:=xlPasteValues
    whishodniy.[H2].Copy: lobjDB.DataBodyRange(lngI, 8).PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.Save 'сохраняем результат чтобы ничего не потерять
    Application.CutCopyMode = False
    Application.ScreenUpdating = True 'включаем обратно обновление экрана.
End Sub
Очень рассчитываю на помощь присутствующих!  
 
 
 
#2
21.07.2019 14:50:31
Доброе время суток.
Вариант
Код
Public Sub addNewRowsFromTable()
    Dim whishodniy As Worksheet, whBD As Worksheet, lobjDB As ListObject, lngI As Long
    Dim arrData
    Set whishodniy = Worksheets("Таблица исходная"): Set whBD = Worksheets("Таблица для вставки"): Set lobjDB = whBD.ListObjects("ТаблицаЗначений")
    lngI = whishodniy.Cells(whishodniy.Rows.Count, 1).End(xlUp).Row
    arrData = whishodniy.Range(whishodniy.Cells(2, whishodniy.UsedRange.Column), whishodniy.Cells(lngI, whishodniy.UsedRange.Columns.Count + whishodniy.UsedRange.Column - 1)).Value
    If lobjDB.DataBodyRange Is Nothing Then
        lobjDB.HeaderRowRange(1).Offset(1, 0).Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    Else
        lobjDB.DataBodyRange.Cells(lobjDB.DataBodyRange.Rows.Count, 1).Offset(1, 0).Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    End If
End Sub

ОБъясните, пожалуйста,
Цитата
только не пустые
зачем это требование? Если вы добавляете данные в таблицу
Цитата
met.constr написал:
добавить их как новые строки ниже в "Умную таблицу"
То если в ячейки этих добавленных строк ничего не будет вставлено, то они будут пустые. Тогда если мы вставим пустые значения при копировании - что изменится в их состоянии?
 
 
 
#3
21.07.2019 20:42:57
Андрей VG, добрый вечер!
В принципе вариант рабочий. Единственное что если в исходную таблицу товары добавлять  через строку, а не подряд, то потом и пустые строки добавляются.

Цитата
Андрей VG написал:
ОБъясните, пожалуйста,Цитататолько не пустые
Касательно только не пустых, я подразумевал что ячейки в диапозоне по первой строке например А2:H2 должны быть заполнены значениями, это мы считаем не пустым значением, а если исходная таблица содержит заполненные А2:H2 то соотвественно остальные A3:H15 мы считаем пустыми.

Цитата
Андрей VG написал:
зачем это требование? Если вы добавляете данные в таблицу
Как новые строки необходимо добавлять так как не должно быть наложений, тоесть если мы добавляем новые значения, они не должны в таблицу для вставки записаться на уже имеющиеся значения.

Как писал выше, вариант в принципе рабочий, но мне его нужно связать с другими своими строками макроса, могли бы вы Андрей VG, более подробно рассказать что и как действует в макросе или дать комментарий к коду?? Я был бы весьма признателен. Так как не силен в написании макросов.


Код
Public Sub addNewRowsFromTable()
    Dim whishodniy As Worksheet, whBD As Worksheet, lobjDB As ListObject, lngI As Long
    Dim arrData
    Set whishodniy = Worksheets("Таблица исходная"): Set whBD = Worksheets("Таблица для вставки"): Set lobjDB = whBD.ListObjects("ТаблицаЗначений")
    lngI = whishodniy.Cells(whishodniy.Rows.Count, 1).End(xlUp).Row
    arrData = whishodniy.Range(whishodniy.Cells(2, whishodniy.UsedRange.Column), whishodniy.Cells(lngI, whishodniy.UsedRange.Columns.Count + whishodniy.UsedRange.Column - 1)).Value
    If lobjDB.DataBodyRange Is Nothing Then
        lobjDB.HeaderRowRange(1).Offset(1, 0).Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    Else
        lobjDB.DataBodyRange.Cells(lobjDB.DataBodyRange.Rows.Count, 1).Offset(1, 0).Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    End If
End Sub

За ранее спасибо!  
Изменено: met.constr - 21.07.2019 20:44:00
 
 
 
Страницы: 1
Наверх