Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос для копирования строк с нескольких листов в новый
 
Прошу помочь в создании макроса.
1. С листа 1 все непустые строки без заголовка скопировать на лист Список в первую пустую строку после заголовка
2. С листа 2 все непустые строки без заголовка скопировать на лист Список в первую пустую строку после строк, скопированных с листа 1.
Копировать данные нужно только с отдельных листов книги, например, "Лист1, Лист2" и т.д.
В рабочем варианте листов много, копирование данных необходимо только с некоторых.

Не могу разобраться, как копировать, чтобы строки с разных листов в итоговом листе шли последовательно.
Спасибо.
 
Два варианта:
- перенос значений + отрисовка границ ячеек в принимающей таблице
Код
Sub MassCopyValues()
Dim a&, arr(), x&, aa, b%, dt$
dt = "A:C" 'диапазон столбцов для переноса
aa = Array("Лист1", "Лист2") 'список названий листов
a = Columns(dt).Find(What:="*", SearchDirection:=2, SearchOrder:=1).Row + 1 'определение последней заполненной строки
For b = 0 To UBound(aa)
  x = Sheets(aa(b)).Columns(dt).Find(What:="*", SearchDirection:=2, SearchOrder:=1).Row 'определение последней заполненной строки
  If x > 1 Then
    arr = Sheets(aa(b)).Columns(dt).Rows("2:" & x).Value
    With Sheets("Список").Range(Left(dt, 1) & a).Resize(UBound(arr, 1), UBound(arr, 2))
      .Value = arr
      .Borders.LineStyle = xlContinuous
    End With
    a = a + UBound(arr)
  End If
Next
End Sub
- полное копирование
Код
Sub MassCopyall()
Dim a&, x&, aa, b%, dt$
dt = "A:C" 'диапазон столбцов для переноса
aa = Array("Лист1", "Лист2") 'список названий листов
For b = 0 To UBound(aa)
  a = Columns(dt).Find(What:="*", SearchDirection:=2, SearchOrder:=1).Row + 1 'определение последней заполненной строки
  x = Sheets(aa(b)).Columns(dt).Find(What:="*", SearchDirection:=2, SearchOrder:=1).Row 'определение последней заполненной строки
  If x > 1 Then
    Sheets(aa(b)).Columns(dt).Rows("2:" & x).Copy Sheets("Список").Range(Left(dt, 1) & a)
  End If
Next
End Sub
 
Anchoret,

Отлично работает. Большое спасибо (за комментарии особенно).
Страницы: 1
Читают тему (гостей: 2)