Домашняя страница 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
Группа: Пользователи
Ранг: Участник
Сообщений: 73
Репутация: 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
Группа: Друзья
Ранг: Старожил
Сообщений: 1762
Репутация: 496 ±
Замечаний: 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]


Skype: andre.tm.007
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
Группа: Пользователи
Ранг: Участник
Сообщений: 73
Репутация: 0 ±
Замечаний: 0% ±

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

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

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

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

Excel 2010
А можно ли оптимизировать макрос AndreTM для более быстрого выполнения. Спасибо!
 
Ответить
СообщениеА можно ли оптимизировать макрос AndreTM для более быстрого выполнения. Спасибо!

Автор - djon2012
Дата добавления - 10.09.2017 в 11:59
InExSu Дата: Воскресенье, 10.09.2017, 13:04 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 163
Репутация: 19 ±
Замечаний: 60% ±

Excel 2010
на скорость не проверял.
[vba]
Код
Sub djon2012_InExSu()
  Application.ScreenUpdating = False
  НачатьСоСтолбца = 3000 - 1
  Столбцов = Range("a1").CurrentRegion.Columns.Count
  For i = 1 To 17
    Randomize: БерёмСтолбец = CLng((1 + Столбцов - 1) * Rnd)
    Columns(БерёмСтолбец).Copy Columns(НачатьСоСтолбца + i)
  Next
  Application.ScreenUpdating = True
End Sub
[/vba]
 
Ответить
Сообщениена скорость не проверял.
[vba]
Код
Sub djon2012_InExSu()
  Application.ScreenUpdating = False
  НачатьСоСтолбца = 3000 - 1
  Столбцов = Range("a1").CurrentRegion.Columns.Count
  For i = 1 To 17
    Randomize: БерёмСтолбец = CLng((1 + Столбцов - 1) * Rnd)
    Columns(БерёмСтолбец).Copy Columns(НачатьСоСтолбца + i)
  Next
  Application.ScreenUpdating = True
End Sub
[/vba]

Автор - InExSu
Дата добавления - 10.09.2017 в 13:04
djon2012 Дата: Воскресенье, 10.09.2017, 17:38 | Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 73
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Спасибо InExSu!!! Попробую.
 
Ответить
СообщениеСпасибо InExSu!!! Попробую.

Автор - djon2012
Дата добавления - 10.09.2017 в 17:38
djon2012 Дата: Воскресенье, 10.09.2017, 23:41 | Сообщение № 8
Группа: Пользователи
Ранг: Участник
Сообщений: 73
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Протестировал ваш макрос InExSu, скорость выполнения аналогична скорости макроса AndreTM. Спасибо!
 
Ответить
СообщениеПротестировал ваш макрос InExSu, скорость выполнения аналогична скорости макроса AndreTM. Спасибо!

Автор - djon2012
Дата добавления - 10.09.2017 в 23:41
Manyasha Дата: Понедельник, 11.09.2017, 19:35 | Сообщение № 9
Группа: Модераторы
Ранг: Старожил
Сообщений: 1974
Репутация: 817 ±
Замечаний: 0% ±

Excel 2010, 2016
djon2012, вот так по идее побыстрее должно быть (чуть изменила макрос AndreTM):
[vba]
Код
Sub test()
    Dim addr$, lr&
    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
    Dim t: t = Timer
    lr = tbl.Rows.Count
    
    ' почистим место назначения
    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)
        addr = addr & "," & tbl.Columns(numArray(num)).Address
        temp = numArray(i)
        numArray(i) = numArray(num)
        numArray(num) = temp
    Next
    addr = Mid(addr, 2)
    Range(addr).Copy dest
    Debug.Print Timer - t
    ' и пойдем посмотреть результат
    dest.Select
End Sub
[/vba]

еще можно через массивы попробовать.


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеdjon2012, вот так по идее побыстрее должно быть (чуть изменила макрос AndreTM):
[vba]
Код
Sub test()
    Dim addr$, lr&
    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
    Dim t: t = Timer
    lr = tbl.Rows.Count
    
    ' почистим место назначения
    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)
        addr = addr & "," & tbl.Columns(numArray(num)).Address
        temp = numArray(i)
        numArray(i) = numArray(num)
        numArray(num) = temp
    Next
    addr = Mid(addr, 2)
    Range(addr).Copy dest
    Debug.Print Timer - t
    ' и пойдем посмотреть результат
    dest.Select
End Sub
[/vba]

еще можно через массивы попробовать.

Автор - Manyasha
Дата добавления - 11.09.2017 в 19:35
djon2012 Дата: Вторник, 12.09.2017, 07:21 | Сообщение № 10
Группа: Пользователи
Ранг: Участник
Сообщений: 73
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте Manyasha! Спасибо за ваш вариант, почему то в строке Range(addr).Copy dest выдает ошибку Method 'Range' of object '_Global' failed.
 
Ответить
СообщениеЗдравствуйте Manyasha! Спасибо за ваш вариант, почему то в строке Range(addr).Copy dest выдает ошибку Method 'Range' of object '_Global' failed.

Автор - djon2012
Дата добавления - 12.09.2017 в 07:21
djon2012 Дата: Среда, 20.09.2017, 22:29 | Сообщение № 11
Группа: Пользователи
Ранг: Участник
Сообщений: 73
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
А как сделать это через массивы?
 
Ответить
СообщениеА как сделать это через массивы?

Автор - djon2012
Дата добавления - 20.09.2017 в 22:29
InExSu Дата: Четверг, 21.09.2017, 08:51 | Сообщение № 12
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 163
Репутация: 19 ±
Замечаний: 60% ±

Excel 2010
через массивы?
[vba]
Код
Sub djon2012_InExSu_arr_briefly()
  arr01 = Worksheets(1).UsedRange.Value
  Колонок = UBound(arr01, 2)
  НужноКолонок = 17
  ReDim arr02(UBound(arr01), НужноКолонок)
  For i = 1 To НужноКолонок
    Randomize: БерёмКолонку = CLng((1 + Колонок - 1) * Rnd)
    For j = 1 To UBound(arr02)
      arr02(j, i) = arr01(j, БерёмКолонку)
    Next
  Next
  Sheets.Add After:=Sheets(Sheets.Count)
  Cells(1, 1).Resize(UBound(arr02), UBound(arr02, 2)) = arr02
End Sub
[/vba]
а где это используется?


Сообщение отредактировал InExSu - Четверг, 21.09.2017, 08:52
 
Ответить
Сообщение
через массивы?
[vba]
Код
Sub djon2012_InExSu_arr_briefly()
  arr01 = Worksheets(1).UsedRange.Value
  Колонок = UBound(arr01, 2)
  НужноКолонок = 17
  ReDim arr02(UBound(arr01), НужноКолонок)
  For i = 1 To НужноКолонок
    Randomize: БерёмКолонку = CLng((1 + Колонок - 1) * Rnd)
    For j = 1 To UBound(arr02)
      arr02(j, i) = arr01(j, БерёмКолонку)
    Next
  Next
  Sheets.Add After:=Sheets(Sheets.Count)
  Cells(1, 1).Resize(UBound(arr02), UBound(arr02, 2)) = arr02
End Sub
[/vba]
а где это используется?

Автор - InExSu
Дата добавления - 21.09.2017 в 08:51
djon2012 Дата: Четверг, 21.09.2017, 09:16 | Сообщение № 13
Группа: Пользователи
Ранг: Участник
Сообщений: 73
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Спасибо Вам InExSu за макрос! А использую я его (с некоторыми модификациями) для обработки статистических данных. Поскольку этих самых данных огого, то нужен макрос который бы наиболее шустро эти данные обрабатывал. Еще раз огромное Вам спасибо!
 
Ответить
СообщениеСпасибо Вам InExSu за макрос! А использую я его (с некоторыми модификациями) для обработки статистических данных. Поскольку этих самых данных огого, то нужен макрос который бы наиболее шустро эти данные обрабатывал. Еще раз огромное Вам спасибо!

Автор - djon2012
Дата добавления - 21.09.2017 в 09:16
djon2012 Дата: Четверг, 21.09.2017, 23:46 | Сообщение № 14
Группа: Пользователи
Ранг: Участник
Сообщений: 73
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
InExSu я проверил Ваш вариант макроса так сказать в "боевых действиях". Скорость выполнения к сожалению уступает в быстродействии макроса от AndreTM, да и косячит немного. Спасибо!
 
Ответить
СообщениеInExSu я проверил Ваш вариант макроса так сказать в "боевых действиях". Скорость выполнения к сожалению уступает в быстродействии макроса от AndreTM, да и косячит немного. Спасибо!

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

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