Здравствуйте! Помогите пожалуйста решить небольшую задачку. Суть задачи такова, в приложенном примере в Лист1 имеются столбцы с данными (244 столбца, в реальных условиях около 2000). Каждый столбец ограничивается данными с 1-ой по 1351 -ую ячейку по строкам. Мне нужно случайным образом отобрать столбцы в количестве скажем 17 штук и скопировать их в ячейку DKJ1. Спасибо!
Здравствуйте! Помогите пожалуйста решить небольшую задачку. Суть задачи такова, в приложенном примере в Лист1 имеются столбцы с данными (244 столбца, в реальных условиях около 2000). Каждый столбец ограничивается данными с 1-ой по 1351 -ую ячейку по строкам. Мне нужно случайным образом отобрать столбцы в количестве скажем 17 штук и скопировать их в ячейку DKJ1. Спасибо!djon2012
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]
Можно как-то вот так: [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
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]
еще можно через массивы попробовать.
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
Здравствуйте Manyasha! Спасибо за ваш вариант, почему то в строке Range(addr).Copy dest выдает ошибку Method 'Range' of object '_Global' failed.
Здравствуйте Manyasha! Спасибо за ваш вариант, почему то в строке Range(addr).Copy dest выдает ошибку Method 'Range' of object '_Global' failed.djon2012
Спасибо Вам InExSu за макрос! А использую я его (с некоторыми модификациями) для обработки статистических данных. Поскольку этих самых данных огого, то нужен макрос который бы наиболее шустро эти данные обрабатывал. Еще раз огромное Вам спасибо!
Спасибо Вам InExSu за макрос! А использую я его (с некоторыми модификациями) для обработки статистических данных. Поскольку этих самых данных огого, то нужен макрос который бы наиболее шустро эти данные обрабатывал. Еще раз огромное Вам спасибо!djon2012
InExSu я проверил Ваш вариант макроса так сказать в "боевых действиях". Скорость выполнения к сожалению уступает в быстродействии макроса от AndreTM, да и косячит немного. Спасибо!
InExSu я проверил Ваш вариант макроса так сказать в "боевых действиях". Скорость выполнения к сожалению уступает в быстродействии макроса от AndreTM, да и косячит немного. Спасибо!djon2012
Здравствуйте! Еще раз хочу поблагодарить всех кто помог в даной теме (и не только в ней). Использую вариант AndreTM, все работало нормально но как только я изменил входные данные, макрос перестал корректно копировать случайные столбцы. VBA понимаю очень поверхностно и разобраться что надо изменить в макросе не хватает знаний (возможно "шариков" или "шестеренок"). Помогите пожалуйста! Прикрепляю 2 файла в одно все работает нормально в другом нет. Столбцы должны копироваться по 4000 строку. Спасибо!!!
Здравствуйте! Еще раз хочу поблагодарить всех кто помог в даной теме (и не только в ней). Использую вариант AndreTM, все работало нормально но как только я изменил входные данные, макрос перестал корректно копировать случайные столбцы. VBA понимаю очень поверхностно и разобраться что надо изменить в макросе не хватает знаний (возможно "шариков" или "шестеренок"). Помогите пожалуйста! Прикрепляю 2 файла в одно все работает нормально в другом нет. Столбцы должны копироваться по 4000 строку. Спасибо!!!djon2012
Привет! На листе данных не должно быть других данных, кроме нужных данных .
Замените строку
[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, сюда не заходит ...
Привет! На листе данных не должно быть других данных, кроме нужных данных .
Замените строку
[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))