Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Разбить несколько таблиц расположенных вертикально по горизонтали
 
#1
18.05.2018 14:08:18
Доброго времени суток уважаемые форумчане просьба помочь в решении вопроса!
Задача следующая:
В несколько столбцов расположены таблицы (макет таблиц одинаковый различаются только данные внутри таблиц и количество строк) Так как в VBA далеко не профи (от слова совсем) нужен макрос позволяющий переносить каждую таблицу рядом (то есть выстроить их горизонтально). Возможно кто то сталкивался??? Спасибо за любую помощь!!!
...И да формула к сожалению не подойдет -пробовал (формула бы помогла с маленьким диапазоном, но так как таблица из которой нужно выдернуть данные очень большая порядка 50 тысяч строк эксель начинает умирать от объема по этому нужен именно макрос! Пример прилагаю! СПАСИБО!    
 
 
 
#2
18.05.2018 14:15:59
Цитата
так как таблица из которой нужно выдернуть данные очень большая порядка 50 тысяч строк
А столбцов то вам хватит?
 
 
 
#3
18.05.2018 14:24:01
Да 16+ тысяч думаю хватит, мне главное понять принцип макроса от этого и буду плясать.  
 
 
 
#4
18.05.2018 14:25:36
Цитата
max2608 написал:
50 тысяч строк эксель
хм...уверены?
Цитата
max2608 написал:
16+ тысяч думаю хватит
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#5
18.05.2018 14:36:15
Да конечно все строки (около 50 тысяч) уйдут на 480 таблиц по горизонтали в каждой таблице по 6 столбцов + 1 столбец на разделение таблиц между собой и того 6*480+480=3360
 
 
 
#6
18.05.2018 14:36:58
Код
Sub JustDoIt()
  Dim cnt&, r&
  r = 1: cnt = 1
  Do While r < Rows.Count
    Cells(r, 1).CurrentRegion.Copy Cells(1, cnt * 7 + 1): cnt = cnt + 1
    r = Cells(r, 1).End(xlDown).End(xlDown).Row
  Loop
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#7
18.05.2018 14:51:11
Код
Sub ReNew()

   Dim rw As Long, i As Long
   Dim rws As Collection
   
   Set rws = New Collection
   rw = 1
   Do While rw < Cells(Rows.Count, 1).End(xlUp).Row
      rw = Cells(rw, 1).End(xlDown).Row + 2
      If rw < Cells(Rows.Count, 1).End(xlUp).Row Then rws.Add rw
   Loop
   For rw = 1 To rws.Count
      i = rws(rw)
      Range(Cells(rws(rw), 1), Cells(Cells(rws(rw), 1).End(xlDown).Row, Cells(rws(rw), Columns.Count).End(xlToLeft).Column)).Cut
      Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 2).Select
      ActiveSheet.Paste
   Next rw

End Sub
Изменено: StoTisteg - 18.05.2018 14:52:55
 
 
 
#8
18.05.2018 16:06:42
Огромное спасибо!!!! Буду думать дальше!)
 
 
 
Страницы: 1
Наверх