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

Вход

Регистрация

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

 

= Мир MS Excel/Разноска данных по столбцам - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разноска данных по столбцам (Макросы/Sub)
Разноска данных по столбцам
rtv206 Дата: Вторник, 26.11.2019, 21:31 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 57
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Доброго времени суток уважаемые форумчане!
В который раз прошу Вашей помощи в решении проблемы:
Есть файл (Лист 1) в столбце А в котором есть данные.
Эти данные необходимо разнести в таблицу по 700 штук (7 столбцов по 100 штук в каждом).
После разноски необходимо эти строки пронумеровать.
Количество данных в столбце А может быть разное.
Все столбцы должны быть полными, по 100 штук.
Если количество не кратное 700 то необходимо что бы в последней таблице не полными были последние столбцы.
Результат выполнения макроса приведен на Лист2
заранее благодарю за помощь!)
К сообщению приложен файл: 1258.xlsx(37.0 Kb)
 
Ответить
СообщениеДоброго времени суток уважаемые форумчане!
В который раз прошу Вашей помощи в решении проблемы:
Есть файл (Лист 1) в столбце А в котором есть данные.
Эти данные необходимо разнести в таблицу по 700 штук (7 столбцов по 100 штук в каждом).
После разноски необходимо эти строки пронумеровать.
Количество данных в столбце А может быть разное.
Все столбцы должны быть полными, по 100 штук.
Если количество не кратное 700 то необходимо что бы в последней таблице не полными были последние столбцы.
Результат выполнения макроса приведен на Лист2
заранее благодарю за помощь!)

Автор - rtv206
Дата добавления - 26.11.2019 в 21:31
Kuzmich Дата: Вторник, 26.11.2019, 23:01 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 430
Репутация: 88 ±
Замечаний: 0% ±

Excel 2003
Запускать при активном Лист1
[vba]
Код
Sub Razbienie()
Dim i As Long
Dim iLastRow As Long
Dim j As Long
Dim arr
Dim arr_n
Dim Kol_vo As Long
Dim n As Long
Dim iCounter As Long
  Kol_vo = 100
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
n = Int(iLastRow / Kol_vo) + 1
arr = Range("A1:A" & iLastRow).Value
ReDim arr_n(1 To Kol_vo, 1 To n * 2)
    iCounter = 1
  For j = 1 To UBound(arr_n, 2) Step 2
    For i = 1 To UBound(arr_n)
      If iCounter <= iLastRow Then
        arr_n(i, j) = iCounter
        arr_n(i, j + 1) = arr(iCounter, 1)
        iCounter = iCounter + 1
      End If
    Next
  Next
  With Worksheets("Лист2")
    .Cells.Clear
    .Range("A1").Resize(Kol_vo, n * 2) = arr_n
    .Range(.Cells(1, n + 1), .Cells(100, n * 2)).Cut .Range("A103")
  End With
End Sub
[/vba]
 
Ответить
СообщениеЗапускать при активном Лист1
[vba]
Код
Sub Razbienie()
Dim i As Long
Dim iLastRow As Long
Dim j As Long
Dim arr
Dim arr_n
Dim Kol_vo As Long
Dim n As Long
Dim iCounter As Long
  Kol_vo = 100
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
n = Int(iLastRow / Kol_vo) + 1
arr = Range("A1:A" & iLastRow).Value
ReDim arr_n(1 To Kol_vo, 1 To n * 2)
    iCounter = 1
  For j = 1 To UBound(arr_n, 2) Step 2
    For i = 1 To UBound(arr_n)
      If iCounter <= iLastRow Then
        arr_n(i, j) = iCounter
        arr_n(i, j + 1) = arr(iCounter, 1)
        iCounter = iCounter + 1
      End If
    Next
  Next
  With Worksheets("Лист2")
    .Cells.Clear
    .Range("A1").Resize(Kol_vo, n * 2) = arr_n
    .Range(.Cells(1, n + 1), .Cells(100, n * 2)).Cut .Range("A103")
  End With
End Sub
[/vba]

Автор - Kuzmich
Дата добавления - 26.11.2019 в 23:01
rtv206 Дата: Среда, 27.11.2019, 13:32 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 57
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Kuzmich, спасибо буду пробовать)
 
Ответить
СообщениеKuzmich, спасибо буду пробовать)

Автор - rtv206
Дата добавления - 27.11.2019 в 13:32
_Boroda_ Дата: Среда, 27.11.2019, 16:50 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 15644
Репутация: 6114 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Еще вариант
[vba]
Код
Sub tt()
    k_ = 100
    With Worksheets("Лист2")
        .Cells.Clear
        For i = 1 To Cells(Rows.Count, 1).End(3).Row / k_
            .Cells(2, i).Resize(k_) = Cells(1, 1).Offset(k_ * (i - 1)).Resize(k_).Value
        Next i
        .Select
    End With
End Sub
[/vba]
К сообщению приложен файл: 1258_1.xlsm(38.2 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеЕще вариант
[vba]
Код
Sub tt()
    k_ = 100
    With Worksheets("Лист2")
        .Cells.Clear
        For i = 1 To Cells(Rows.Count, 1).End(3).Row / k_
            .Cells(2, i).Resize(k_) = Cells(1, 1).Offset(k_ * (i - 1)).Resize(k_).Value
        Next i
        .Select
    End With
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 27.11.2019 в 16:50
rtv206 Дата: Четверг, 28.11.2019, 12:44 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 57
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
_Boroda_, Спасибо большое за помощь!
Ваш макрос только разделяет на столбцы, а нет автоматической нумерации)
 
Ответить
Сообщение_Boroda_, Спасибо большое за помощь!
Ваш макрос только разделяет на столбцы, а нет автоматической нумерации)

Автор - rtv206
Дата добавления - 28.11.2019 в 12:44
rtv206 Дата: Четверг, 28.11.2019, 12:49 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 57
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Kuzmich, при переходе в ячейку A103 сначала идут данные а потом номер по порядку, хотя должно быть наоборот.
Подскажите, пожалуйста, как сделать что бы все данные переносились в столбцы от 1-100, не разбиваясь ниже 100 столбца?
 
Ответить
СообщениеKuzmich, при переходе в ячейку A103 сначала идут данные а потом номер по порядку, хотя должно быть наоборот.
Подскажите, пожалуйста, как сделать что бы все данные переносились в столбцы от 1-100, не разбиваясь ниже 100 столбца?

Автор - rtv206
Дата добавления - 28.11.2019 в 12:49
Kuzmich Дата: Четверг, 28.11.2019, 13:53 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 430
Репутация: 88 ±
Замечаний: 0% ±

Excel 2003
Цитата
что бы все данные переносились в столбцы от 1-100, не разбиваясь

Уберите строку
[vba]
Код
.Range(.Cells(1, n + 1), .Cells(100, n * 2)).Cut .Range("A103")
[/vba]
 
Ответить
Сообщение
Цитата
что бы все данные переносились в столбцы от 1-100, не разбиваясь

Уберите строку
[vba]
Код
.Range(.Cells(1, n + 1), .Cells(100, n * 2)).Cut .Range("A103")
[/vba]

Автор - Kuzmich
Дата добавления - 28.11.2019 в 13:53
rtv206 Дата: Четверг, 28.11.2019, 14:19 | Сообщение № 8
Группа: Пользователи
Ранг: Участник
Сообщений: 57
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Kuzmich, спасибо огромное)))))
 
Ответить
СообщениеKuzmich, спасибо огромное)))))

Автор - rtv206
Дата добавления - 28.11.2019 в 14:19
_Boroda_ Дата: Пятница, 29.11.2019, 16:48 | Сообщение № 9
Группа: Модераторы
Ранг: Местный житель
Сообщений: 15644
Репутация: 6114 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Ваш макрос только разделяет на столбцы, а нет автоматической нумерации)

Да, это я что-то стормозил
Тогда такой вариант
[vba]
Код
Sub tt()
    k_ = 100
    kk_ = 7
    n_ = Cells(Rows.Count, 1).End(3).Row
    With Worksheets("Лист2")
        Application.ScreenUpdating = 0
        cal_ = Application.Calculation
        Application.Calculation = 3
        .Cells.Clear
        r0_ = 2
        x_ = k_
        For j = 1 To -Int(-n_ / k_ / kk_)
            For i = 2 To kk_ * 2 Step 2
                a_ = k_ * (i / 2 + (j - 1) * kk_)
                If a_ > n_ Then
                    x_ = n_ - a_ + k_
                    fl_ = 1
                End If
                .Cells(r0_, i).Resize(x_) = Cells(1, 1).Offset(a_ - k_).Resize(x_).Value
                .Cells(r0_, i - 1) = k_ * (i / 2 - 1 + (j - 1) * kk_) + 1
                .Cells(r0_, i - 1).Resize(x_).DataSeries
                If fl_ Then Exit For
            Next i
            r0_ = r0_ + k_ + 2
        Next j
        Application.Calculation = cal_
        Application.ScreenUpdating = 1
        .Select
    End With
End Sub
[/vba]
Получается немного иначе, чем при запуске макроса Владимира. Особенно, если значений много, я пробовал на 2112 записей
К сообщению приложен файл: 1258_2.xlsm(61.3 Kb)


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

Да, это я что-то стормозил
Тогда такой вариант
[vba]
Код
Sub tt()
    k_ = 100
    kk_ = 7
    n_ = Cells(Rows.Count, 1).End(3).Row
    With Worksheets("Лист2")
        Application.ScreenUpdating = 0
        cal_ = Application.Calculation
        Application.Calculation = 3
        .Cells.Clear
        r0_ = 2
        x_ = k_
        For j = 1 To -Int(-n_ / k_ / kk_)
            For i = 2 To kk_ * 2 Step 2
                a_ = k_ * (i / 2 + (j - 1) * kk_)
                If a_ > n_ Then
                    x_ = n_ - a_ + k_
                    fl_ = 1
                End If
                .Cells(r0_, i).Resize(x_) = Cells(1, 1).Offset(a_ - k_).Resize(x_).Value
                .Cells(r0_, i - 1) = k_ * (i / 2 - 1 + (j - 1) * kk_) + 1
                .Cells(r0_, i - 1).Resize(x_).DataSeries
                If fl_ Then Exit For
            Next i
            r0_ = r0_ + k_ + 2
        Next j
        Application.Calculation = cal_
        Application.ScreenUpdating = 1
        .Select
    End With
End Sub
[/vba]
Получается немного иначе, чем при запуске макроса Владимира. Особенно, если значений много, я пробовал на 2112 записей

Автор - _Boroda_
Дата добавления - 29.11.2019 в 16:48
rtv206 Дата: Воскресенье, 01.12.2019, 17:27 | Сообщение № 10
Группа: Пользователи
Ранг: Участник
Сообщений: 57
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
_Boroda_, спасибо огромное за помощь!)
 
Ответить
Сообщение_Boroda_, спасибо огромное за помощь!)

Автор - rtv206
Дата добавления - 01.12.2019 в 17:27
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разноска данных по столбцам (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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