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

Вход

Регистрация

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

 

= Мир MS Excel/Случайный отбор столбцов и копирование их в другое место - Мир MS Excel

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

Excel 2010
Здравствуйте!
Помогите пожалуйста решить небольшую задачку. Суть задачи такова, в приложенном примере в Лист1 имеются столбцы с данными (244 столбца, в реальных условиях около 2000). Каждый столбец ограничивается данными с 1-ой по 1351 -ую ячейку по строкам. Мне нужно случайным образом отобрать столбцы в количестве скажем 17 штук и скопировать их в ячейку DKJ1. Спасибо!
К сообщению приложен файл: 2112251.xlsb(84Kb)
 
Ответить
СообщениеЗдравствуйте!
Помогите пожалуйста решить небольшую задачку. Суть задачи такова, в приложенном примере в Лист1 имеются столбцы с данными (244 столбца, в реальных условиях около 2000). Каждый столбец ограничивается данными с 1-ой по 1351 -ую ячейку по строкам. Мне нужно случайным образом отобрать столбцы в количестве скажем 17 штук и скопировать их в ячейку DKJ1. Спасибо!

Автор - djon2012
Дата добавления - 15.07.2017 в 09:38
AndreTM Дата: Суббота, 15.07.2017, 10:44 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1553
Репутация: 445 ±
Замечаний: 0% ±

2003 & 2010
Можно как-то вот так:
[vba]
Код
Sub test()
    Set tbl = [a1].CurrentRegion ' исходные данные
    Set dest = Cells(1, 3000) ' место назначения
    If Not Intersect(tbl, dest) Is Nothing Then
        MsgBox "Место назначения находится в диапазоне с данными"
        Exit Sub
    End If
    
    destColumnsCount = 17 ' количество колонок для отбора
    If tbl.Columns.Count < destColumnsCount Then
        MsgBox "Вы пытаетесь отобрать больше данных, чем имеется"
        Exit Sub
    End If
    
    ' почистим место назначения
    dest.Resize( _
        WorksheetFunction.Max(dest.CurrentRegion.Rows.Count, tbl.Rows.Count), _
        WorksheetFunction.Max(dest.CurrentRegion.Columns.Count, destColumnsCount) _
        ).ClearContents
    
    ' отберем случайные столбцы из всего диапазона, одновременно копируя их
    ReDim numArray(1 To tbl.Columns.Count)
    For i = 1 To tbl.Columns.Count
        numArray(i) = i
    Next
    For i = 1 To destColumnsCount
        num = WorksheetFunction.RandBetween(i, tbl.Columns.Count)
        tbl.Columns(numArray(num)).Copy dest.Offset(, i - 1)
        temp = numArray(i)
        numArray(i) = numArray(num)
        numArray(num) = temp
    Next
    
    ' и пойдем посмотреть результат
    dest.Select
End Sub
[/vba]


Donate: Qiwi: 9517375010

Сообщение отредактировал AndreTM - Суббота, 15.07.2017, 10:51
 
Ответить
СообщениеМожно как-то вот так:
[vba]
Код
Sub test()
    Set tbl = [a1].CurrentRegion ' исходные данные
    Set dest = Cells(1, 3000) ' место назначения
    If Not Intersect(tbl, dest) Is Nothing Then
        MsgBox "Место назначения находится в диапазоне с данными"
        Exit Sub
    End If
    
    destColumnsCount = 17 ' количество колонок для отбора
    If tbl.Columns.Count < destColumnsCount Then
        MsgBox "Вы пытаетесь отобрать больше данных, чем имеется"
        Exit Sub
    End If
    
    ' почистим место назначения
    dest.Resize( _
        WorksheetFunction.Max(dest.CurrentRegion.Rows.Count, tbl.Rows.Count), _
        WorksheetFunction.Max(dest.CurrentRegion.Columns.Count, destColumnsCount) _
        ).ClearContents
    
    ' отберем случайные столбцы из всего диапазона, одновременно копируя их
    ReDim numArray(1 To tbl.Columns.Count)
    For i = 1 To tbl.Columns.Count
        numArray(i) = i
    Next
    For i = 1 To destColumnsCount
        num = WorksheetFunction.RandBetween(i, tbl.Columns.Count)
        tbl.Columns(numArray(num)).Copy dest.Offset(, i - 1)
        temp = numArray(i)
        numArray(i) = numArray(num)
        numArray(num) = temp
    Next
    
    ' и пойдем посмотреть результат
    dest.Select
End Sub
[/vba]

Автор - AndreTM
Дата добавления - 15.07.2017 в 10:44
djon2012 Дата: Суббота, 15.07.2017, 13:02 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
AndreTM БОЛЬШОЕ Спасибо! Попробую работу макроса в действии отпишусь.
 
Ответить
СообщениеAndreTM БОЛЬШОЕ Спасибо! Попробую работу макроса в действии отпишусь.

Автор - djon2012
Дата добавления - 15.07.2017 в 13:02
djon2012 Дата: Суббота, 15.07.2017, 13:58 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Урааа заработало hands hands hands Спасибо!!!
 
Ответить
СообщениеУрааа заработало hands hands hands Спасибо!!!

Автор - djon2012
Дата добавления - 15.07.2017 в 13:58
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Случайный отбор столбцов и копирование их в другое место (Макросы/Sub)
Страница 1 из 11
Поиск:

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