Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Присоединить куски данных один к одному вниз - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Присоединить куски данных один к одному вниз (Макросы/Sub)
Присоединить куски данных один к одному вниз
ant6729 Дата: Суббота, 01.09.2018, 22:48 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация: 2 ±
Замечаний: 40% ±

Excel 2010
Всем привет, скажу честно, не знаю, как обозвать тему.

Приложил пример
В нем нужно из левой части сделать правую.
Проблема в том, что можно на макросах
Но я сегодня в свободное на работе время опять сделал какого-то монстра. Он работает...
Но можно ли сделать решение на словарях или иначе, но как-то короче?
Мне кажется, у меня какое-то плато с этим...писать километровый код ...

Вот мой код, но он только воспроизводит логику.
В приложении упрощенный вариант данных.

[vba]
Код
Public Rng
Public Rng2
Sub Runme()

    Call chisla1
    Call chisla2
    Call otdel
    Call month
    Call clean

End Sub

Sub chisla2()

'Stavim chisla2

Set MyCollection = New Collection
Set MyCollection2 = New Collection

On Error Resume Next

For Each Cell In Rng.Cells
    MyCollection.Add Cell.Value, CStr(Cell.Value)
Next Cell

For Each Cell In Rng2.Cells
    MyCollection2.Add Cell.Value, CStr(Cell.Value)
Next Cell

For Each vNum In MyCollection
    lr = Sheets("N").Range("C" & Rows.Count).End(xlUp).Row
    Cells(lr + 1, 3) = vNum
    On Error GoTo 0
Next vNum

For Each vNum In MyCollection2
    lr = Sheets("N").Range("D" & Rows.Count).End(xlUp).Row
    Cells(lr + 1, 4) = vNum
    On Error GoTo 0
Next vNum

End Sub
Sub chisla1()

'Stavim chisla1

Columns(2).Insert
Cells(2, 2).Value = "Period"
i = 0

For k = 4 To Cells(1, Columns.Count).End(xlToLeft).Column

    Set Rng = Range(Cells(3, 5 + i), Cells(12, 5 + i))
    Set Rng2 = Range(Cells(3, 6 + i), Cells(12, 6 + i))
    
    i = i + 2
Call chisla2

Next k

End Sub
Sub otdel()

    'Stavim otdel

lr2 = Sheets("N").Range("C" & Rows.Count).End(xlUp).Row
lr = Sheets("N").Range("A" & Rows.Count).End(xlUp).Row + 1
j = 1

For i = lr + 1 To lr2 + 1

    lr = Sheets("N").Range("A" & Rows.Count).End(xlUp).Row + 1
    Cells(lr, 1) = Cells(2 + j, 1).Value
    j = j + 1

Next i

End Sub

Sub month()

Set Rng3 = Range(Cells(1, 2), Cells(1, 17))
Set MyCollection3 = New Collection

For Each Cell In Rng3.Cells
    If Not Cell.Value Like "" Then MyCollection3.Add Cell.Value, CStr(Cell.Value)
Next Cell

For Each vNum In MyCollection3

    lr = Sheets("N").Range("b" & Rows.Count).End(xlUp).Row + 1
    
    For i = lr To lr + 9
        Cells(i, 2).Value = vNum
    Next i
    On Error GoTo 0
Next vNum

End Sub

Sub clean()
    Range("E1:R12").ClearContents
    Rows(1).Delete
End Sub
[/vba]
К сообщению приложен файл: 8735744.xlsx(9.0 Kb)


Сообщение отредактировал ant6729 - Суббота, 01.09.2018, 22:50
 
Ответить
СообщениеВсем привет, скажу честно, не знаю, как обозвать тему.

Приложил пример
В нем нужно из левой части сделать правую.
Проблема в том, что можно на макросах
Но я сегодня в свободное на работе время опять сделал какого-то монстра. Он работает...
Но можно ли сделать решение на словарях или иначе, но как-то короче?
Мне кажется, у меня какое-то плато с этим...писать километровый код ...

Вот мой код, но он только воспроизводит логику.
В приложении упрощенный вариант данных.

[vba]
Код
Public Rng
Public Rng2
Sub Runme()

    Call chisla1
    Call chisla2
    Call otdel
    Call month
    Call clean

End Sub

Sub chisla2()

'Stavim chisla2

Set MyCollection = New Collection
Set MyCollection2 = New Collection

On Error Resume Next

For Each Cell In Rng.Cells
    MyCollection.Add Cell.Value, CStr(Cell.Value)
Next Cell

For Each Cell In Rng2.Cells
    MyCollection2.Add Cell.Value, CStr(Cell.Value)
Next Cell

For Each vNum In MyCollection
    lr = Sheets("N").Range("C" & Rows.Count).End(xlUp).Row
    Cells(lr + 1, 3) = vNum
    On Error GoTo 0
Next vNum

For Each vNum In MyCollection2
    lr = Sheets("N").Range("D" & Rows.Count).End(xlUp).Row
    Cells(lr + 1, 4) = vNum
    On Error GoTo 0
Next vNum

End Sub
Sub chisla1()

'Stavim chisla1

Columns(2).Insert
Cells(2, 2).Value = "Period"
i = 0

For k = 4 To Cells(1, Columns.Count).End(xlToLeft).Column

    Set Rng = Range(Cells(3, 5 + i), Cells(12, 5 + i))
    Set Rng2 = Range(Cells(3, 6 + i), Cells(12, 6 + i))
    
    i = i + 2
Call chisla2

Next k

End Sub
Sub otdel()

    'Stavim otdel

lr2 = Sheets("N").Range("C" & Rows.Count).End(xlUp).Row
lr = Sheets("N").Range("A" & Rows.Count).End(xlUp).Row + 1
j = 1

For i = lr + 1 To lr2 + 1

    lr = Sheets("N").Range("A" & Rows.Count).End(xlUp).Row + 1
    Cells(lr, 1) = Cells(2 + j, 1).Value
    j = j + 1

Next i

End Sub

Sub month()

Set Rng3 = Range(Cells(1, 2), Cells(1, 17))
Set MyCollection3 = New Collection

For Each Cell In Rng3.Cells
    If Not Cell.Value Like "" Then MyCollection3.Add Cell.Value, CStr(Cell.Value)
Next Cell

For Each vNum In MyCollection3

    lr = Sheets("N").Range("b" & Rows.Count).End(xlUp).Row + 1
    
    For i = lr To lr + 9
        Cells(i, 2).Value = vNum
    Next i
    On Error GoTo 0
Next vNum

End Sub

Sub clean()
    Range("E1:R12").ClearContents
    Rows(1).Delete
End Sub
[/vba]

Автор - ant6729
Дата добавления - 01.09.2018 в 22:48
Pelena Дата: Воскресенье, 02.09.2018, 07:11 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 13033
Репутация: 2877 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Может, воспользоваться Готовым решением Редизайнер таблиц
Результат в файле, осталось только удалить лишний столбец В и первую строку
К сообщению приложен файл: 8735744.xlsm(22.4 Kb)


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеМожет, воспользоваться Готовым решением Редизайнер таблиц
Результат в файле, осталось только удалить лишний столбец В и первую строку

Автор - Pelena
Дата добавления - 02.09.2018 в 07:11
_Boroda_ Дата: Воскресенье, 02.09.2018, 12:07 | Сообщение № 3
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12984
Репутация: 5337 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Антон, Вы бы приложили тот файл, от которого макрос (сейчас макрос явно из другого файла).
И словами написали бы - что откуда куда почему.
По коду: 1) разбираться дольше; 2) не факт, что код верный; 3) не факт, что мы правильно поймем


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеАнтон, Вы бы приложили тот файл, от которого макрос (сейчас макрос явно из другого файла).
И словами написали бы - что откуда куда почему.
По коду: 1) разбираться дольше; 2) не факт, что код верный; 3) не факт, что мы правильно поймем

Автор - _Boroda_
Дата добавления - 02.09.2018 в 12:07
ant6729 Дата: Воскресенье, 02.09.2018, 15:19 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация: 2 ±
Замечаний: 40% ±

Excel 2010
Выложил
К сообщению приложен файл: Des.xlsm(21.8 Kb)


Сообщение отредактировал ant6729 - Воскресенье, 02.09.2018, 17:11
 
Ответить
СообщениеВыложил

Автор - ant6729
Дата добавления - 02.09.2018 в 15:19
_Boroda_ Дата: Воскресенье, 02.09.2018, 21:59 | Сообщение № 5
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12984
Репутация: 5337 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
У меня вот так получилось
[vba]
Код
Sub tt()
    nr_ = Cells(Rows.Count, 1).End(3).Row - 2
    nc_ = Cells(2, Columns.Count).End(1).Column
    ar0 = Cells(1, 1).Resize(nr_ + 2, nc_ + 1)
    ReDim ar1(1 To nr_ * (nc_ - 1) / 2, 1 To 4)
    For i = 1 To nc_ / 2
        For j = 1 To nr_
            str_ = j + (i - 1) * nr_
            ar1(str_, 1) = ar0(j + 2, 1)
            ar1(str_, 2) = ar0(1, i * 2)
            ar1(str_, 3) = ar0(j + 2, i * 2)
            ar1(str_, 4) = ar0(j + 2, i * 2 + 1)
        Next j
    Next i
    Application.ScreenUpdating = 0
    Cells(1).Resize(nr_ + 2, nc_).Clear
    Cells(2, 1).Resize(str_, 4) = ar1
    Cells(1, 1) = "SD"
    Cells(1, 2) = "Period"
    Cells(1, 3) = ar0(2, 2)
    Cells(1, 4) = ar0(2, 3)
    Application.ScreenUpdating = 1
End Sub
[/vba]
К сообщению приложен файл: Des_1.xlsm(22.8 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеУ меня вот так получилось
[vba]
Код
Sub tt()
    nr_ = Cells(Rows.Count, 1).End(3).Row - 2
    nc_ = Cells(2, Columns.Count).End(1).Column
    ar0 = Cells(1, 1).Resize(nr_ + 2, nc_ + 1)
    ReDim ar1(1 To nr_ * (nc_ - 1) / 2, 1 To 4)
    For i = 1 To nc_ / 2
        For j = 1 To nr_
            str_ = j + (i - 1) * nr_
            ar1(str_, 1) = ar0(j + 2, 1)
            ar1(str_, 2) = ar0(1, i * 2)
            ar1(str_, 3) = ar0(j + 2, i * 2)
            ar1(str_, 4) = ar0(j + 2, i * 2 + 1)
        Next j
    Next i
    Application.ScreenUpdating = 0
    Cells(1).Resize(nr_ + 2, nc_).Clear
    Cells(2, 1).Resize(str_, 4) = ar1
    Cells(1, 1) = "SD"
    Cells(1, 2) = "Period"
    Cells(1, 3) = ar0(2, 2)
    Cells(1, 4) = ar0(2, 3)
    Application.ScreenUpdating = 1
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 02.09.2018 в 21:59
ant6729 Дата: Воскресенье, 02.09.2018, 23:26 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация: 2 ±
Замечаний: 40% ±

Excel 2010
Спасибо, пропустил через f8, для меня это реально ультра код)

Еще хотел спросить, а два обращения к листу, обращение имеется ввиду это, здесь?

[vba]
Код
   
Cells(1, 3) = ar0(2, 2)
Cells(1, 4) = ar0(2, 3)
[/vba]
 
Ответить
СообщениеСпасибо, пропустил через f8, для меня это реально ультра код)

Еще хотел спросить, а два обращения к листу, обращение имеется ввиду это, здесь?

[vba]
Код
   
Cells(1, 3) = ar0(2, 2)
Cells(1, 4) = ar0(2, 3)
[/vba]

Автор - ant6729
Дата добавления - 02.09.2018 в 23:26
_Boroda_ Дата: Воскресенье, 02.09.2018, 23:36 | Сообщение № 7
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12984
Репутация: 5337 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
[vba]
Код
    Cells(1, 1) = "SD"
    Cells(1, 2) = "Period"
    Cells(1, 3) = ar0(2, 2)
    Cells(1, 4) = ar0(2, 3)
[/vba]
[vba]
Код
Cells(1).Resize(nr_ + 2, nc_).Clear
[/vba]
Это шапка и очистка предыдущих данных, это не считается :D
Обращения к листу вот:
Это с листа взяли данные в массив
[vba]
Код
ar0 = Cells(1, 1).Resize(nr_ + 2, nc_ + 1)
[/vba]
Это из массива положили данные на лист
[vba]
Код
Cells(2, 1).Resize(str_, 4) = ar1
[/vba]
Все остальное крутится уже внутри VBA, без обращения к листу


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение[vba]
Код
    Cells(1, 1) = "SD"
    Cells(1, 2) = "Period"
    Cells(1, 3) = ar0(2, 2)
    Cells(1, 4) = ar0(2, 3)
[/vba]
[vba]
Код
Cells(1).Resize(nr_ + 2, nc_).Clear
[/vba]
Это шапка и очистка предыдущих данных, это не считается :D
Обращения к листу вот:
Это с листа взяли данные в массив
[vba]
Код
ar0 = Cells(1, 1).Resize(nr_ + 2, nc_ + 1)
[/vba]
Это из массива положили данные на лист
[vba]
Код
Cells(2, 1).Resize(str_, 4) = ar1
[/vba]
Все остальное крутится уже внутри VBA, без обращения к листу

Автор - _Boroda_
Дата добавления - 02.09.2018 в 23:36
ant6729 Дата: Воскресенье, 02.09.2018, 23:39 | Сообщение № 8
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация: 2 ±
Замечаний: 40% ±

Excel 2010
А, .. в этом смысле, я понял) Спасибо)
 
Ответить
СообщениеА, .. в этом смысле, я понял) Спасибо)

Автор - ant6729
Дата добавления - 02.09.2018 в 23:39
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Присоединить куски данных один к одному вниз (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!