Страницы: 1
RSS
Макросом скопировать только строки таблицы с не пустыми ячейками во втором столбце
 
Приветствую. Покажите, пожалуйста, как макросом из одной книги в другую книгу скопировать только строки таблицы с не пустыми ячейками во втором столбце. Макрос будет в той книге, куда надо скопировать значения таблицы. Наверное, лучше будет, если обе книги будут открыты перед запуском макроса, потому что книги тяжелые и на открытие надо секунд тридцать.
В файле таблица, которую надо скопировать без пустых ячеек в столбце наличие. Так же показал итоговый результат, только надо такой диапазон в другую книгу.
Книга, из которой копировать таблицу:  Лист Microsoft.xlsm . Название  листа: bb
Книга, в которую копировать таблицу:  Microsoft.xlsm . Название  листа: vv . ячейка A1
 
Цитата
abc1 написал:
макросом
а запросом PQ не устроит?
Соблюдение правил форума не освобождает от модераторского произвола
 
buchlotnik, только макросом. запросом смог бы сам
 
abc1, можно так
Код
Sub csg()
Dim i As Long, lr As Long, FreeCell As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
If lr < 2 Then lr = 2
Range(Cells(2, 1), Cells(lr, 3)).ClearContents
FreeCell = 2
  With Workbooks("Лист Microsoft.xlsm").Sheets("bb")
     For i = 5 To .Cells(.Rows.Count, 3).End(xlUp).Row
         If .Cells(i, 4) <> "" Then
            .Range(.Cells(i, 3), .Cells(i, 5)).Copy Cells(FreeCell, 1)
             FreeCell = FreeCell + 1
          End If
      Next
   End With
End Sub
Изменено: casag - 17.08.2019 22:15:54
 
abc1, или вот такой вариант попробуйте.
Спасибо.
 
casag, Smurov, спасибо за оба варианта. Только эти макросы работают для этого варианта таблицы. Добавил колонку оптовая цена и макрос эту колонку не захватил. Нельзя ли сделать привязку к таблице одной книги? Еще нужно учесть момент: в обеих книгах одинаковые названия таблиц и листов.
 
Цитата
abc1 написал:
Добавил колонку оптовая цена и макрос эту колонку не захватил
А что же Вы СРАЗУ не показали этот столбец?
 
откройте вложенный файл,
откройте файл и сделайте активным лист, куда нужно скопировать данные
выполните этот мощный макрос (он есть во вложенном файле)
Код
Sub GetAvail()
  Workbooks("Лист Microsoft.xlsm").Worksheets("bb").Columns(4).SpecialCells(xlCellTypeConstants).EntireRow.Copy [a1]
End Sub
Изменено: Ігор Гончаренко - 18.08.2019 07:15:22
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, спасибо большое. Макрос работает интересно: если пустых ячеек в указанном столбце нет, то копирует таблицу, причем и имя у таблицы то же. Если же в указанном столбце есть пустые ячейки, то копирует как диапазон. :)  
 
Цитата
Юрий М написал:
СРАЗУ не показали этот столбец?
столбцов будет разное количество
 
Цитата
abc1 написал:
столбцов будет разное количество
И это сразу обговаривайте.
 
Юрий М, согласен. Упустил этот момент.
Если честно, то думал что в макросе будет привязка к таблице, то есть обращение по имени таблицы. Как оказалось, в предложенных макросах этого нет
 
мой макрос не зависит от количества столбцов в таблице, главное чтобы наличие было указано в 4-м (Д)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко написал:
не зависит от количества столбцов в таблице
,более-менее я это понял
Цитата
Ігор Гончаренко написал:
наличие было указано в 4-м
если что как нибудь индекс столбца прикручу или возьму значение из ячейки, в которой формула возвращает номер столбца
 
Решение [Ігор Гончаренко конечно интереснее.
Спасибо.
Код
Public Sub RangeCopy()
Dim arr()
With CreateObject("scripting.dictionary")
    Set a = Workbooks("Лист Microsoft.xlsm").Sheets("vv")
    arr = a.UsedRange.Value
    'Определяем количество столбцов в масииве
   QntCol = UBound(arr, 2)
    For i = 1 To UBound(arr)
        If arr(i, 2) <> "" Then
            .Add .Count, Application.Index(arr, i)
        End If
    Next
    arr = .items
    Set b = ThisWorkbook.Sheets("vv")
    b.Cells(1).Resize(.Count, QntCol) = Application.Transpose(Application.Transpose(arr))
    b.ListObjects.Add(xlSrcRange, b.Cells(1).CurrentRegion, , xlYes).Name = a.ListObjects(1).Name
End With
End Sub
Изменено: Smurov - 18.08.2019 22:09:02
 
Уважаемые форумчане, подскажите, пожалуйста.
Я просто копирую код из модуля.
Вставка не очень красивая.
При помощи чего вы осуществляете копипаст?
Спасибо.
 
Smurov, нажимаю на <...> и вставляю код
 
abc1, спасибо
 
Smurov, если разобрались, то исправьте ))
 
Юрий М, спасибо, поправил пост.
Спасибо.
 
Цитата
abc1 написал:
если что как нибудь индекс столбца прикручу или возьму значение из ячейки, в которой формула возвращает номер столбца
Доделал макрос, процедура находит нужный номер столбца.
Спасибо.
Код
Public Sub RangeCopy()
Dim arr()
With CreateObject("scripting.dictionary")
    Set a = Workbooks("Лист Microsoft.xlsm").Sheets("vv")
    arr = a.UsedRange.Value
    'Находим номер столбца с заголовком "наличие"
    NumCol = Application.Match("наличие", Application.Index(arr, 1))
    'Определяем количество столбцов в масииве
    QntCol = UBound(arr, 2)
    For i = 1 To UBound(arr)
        If arr(i, NumCol) <> "" Then
            .Add .Count, Application.Index(arr, i)
        End If
    Next
    arr = .items
    Set b = ThisWorkbook.Sheets("vv")
    b.Cells(1).Resize(.Count, QntCol) = Application.Transpose(Application.Transpose(arr))
    b.ListObjects.Add(xlSrcRange, b.Cells(1).CurrentRegion, , xlYes).Name = a.ListObjects(1).Name
End With
Изменено: Smurov - 18.08.2019 14:23:37
 
Smurov, спасибо. Все работает
 
Smurov, странно выглядит благодарность самому себе )
Страницы: 1
Наверх