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

Вход

Регистрация

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

 

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

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

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

Автор - djon2012
Дата добавления - 15.07.2017 в 09:38
AndreTM Дата: Суббота, 15.07.2017, 10:44 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1762
Репутация: 500 ±
Замечаний: 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
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

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

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

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

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

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

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

Excel 2010, 365
на скорость не проверял.
[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]


Разработчик Битрикс24 php, Google Apps Script, VBA Excel Windows/Mac
 
Ответить
Сообщениена скорость не проверял.
[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
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

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

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

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

Автор - djon2012
Дата добавления - 10.09.2017 в 23:41
Manyasha Дата: Понедельник, 11.09.2017, 19:35 | Сообщение № 9
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 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]

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


ЯД: 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
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 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
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - djon2012
Дата добавления - 20.09.2017 в 22:29
InExSu Дата: Четверг, 21.09.2017, 08:51 | Сообщение № 12
Группа: Друзья
Ранг: Ветеран
Сообщений: 648
Репутация: 96 ±
Замечаний: 0% ±

Excel 2010, 365
через массивы?
[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]
а где это используется?


Разработчик Битрикс24 php, Google Apps Script, VBA Excel Windows/Mac

Сообщение отредактировал 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
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

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

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

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

Автор - djon2012
Дата добавления - 21.09.2017 в 23:46
djon2012 Дата: Суббота, 19.05.2018, 22:25 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте! Еще раз хочу поблагодарить всех кто помог в даной теме (и не только в ней). Использую вариант AndreTM, все работало нормально но как только я изменил входные данные, макрос перестал корректно копировать случайные столбцы. VBA понимаю очень поверхностно и разобраться что надо изменить в макросе не хватает знаний (возможно "шариков" или "шестеренок"). Помогите пожалуйста! Прикрепляю 2 файла в одно все работает нормально в другом нет. Столбцы должны копироваться по 4000 строку. Спасибо!!!
К сообщению приложен файл: __--.xlsb (50.6 Kb) · 2625751.xlsb (51.0 Kb)
 
Ответить
СообщениеЗдравствуйте! Еще раз хочу поблагодарить всех кто помог в даной теме (и не только в ней). Использую вариант AndreTM, все работало нормально но как только я изменил входные данные, макрос перестал корректно копировать случайные столбцы. VBA понимаю очень поверхностно и разобраться что надо изменить в макросе не хватает знаний (возможно "шариков" или "шестеренок"). Помогите пожалуйста! Прикрепляю 2 файла в одно все работает нормально в другом нет. Столбцы должны копироваться по 4000 строку. Спасибо!!!

Автор - djon2012
Дата добавления - 19.05.2018 в 22:25
InExSu Дата: Суббота, 19.05.2018, 23:04 | Сообщение № 16
Группа: Друзья
Ранг: Ветеран
Сообщений: 648
Репутация: 96 ±
Замечаний: 0% ±

Excel 2010, 365
Привет!
На листе данных не должно быть других данных, кроме нужных данных deal .

Замените строку

[vba]
Код
Set tbl = [a1].CurrentRegion ' исходные данные
[/vba]

на строки

[vba]
Код
    Dim Row_last As Long, Col_Last As Long
    Row_last = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Col_Last = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Set tbl = Range(Cells(1, 1), Cells(Row_last, Col_Last))
[/vba]

Жаль, что AndreTM, сюда не заходит ...


Разработчик Битрикс24 php, Google Apps Script, VBA Excel Windows/Mac
 
Ответить
СообщениеПривет!
На листе данных не должно быть других данных, кроме нужных данных deal .

Замените строку

[vba]
Код
Set tbl = [a1].CurrentRegion ' исходные данные
[/vba]

на строки

[vba]
Код
    Dim Row_last As Long, Col_Last As Long
    Row_last = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Col_Last = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Set tbl = Range(Cells(1, 1), Cells(Row_last, Col_Last))
[/vba]

Жаль, что AndreTM, сюда не заходит ...

Автор - InExSu
Дата добавления - 19.05.2018 в 23:04
djon2012 Дата: Суббота, 19.05.2018, 23:53 | Сообщение № 17
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 106
Репутация: 0 ±
Замечаний: 0% ±

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

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

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