本文介绍了VBA/宏根据多个条件复制随机行的处理方法,对大家解决问题具有一定的参考价值,需要的朋友们下面随着小编来一起学习吧!
问题描述
我需要帮助才能从具有特定条件的其他工作簿中获取随机行:
I need help to be able to get random rows from another workbook with specific conditions:
如果我单击一个按钮/运行一个宏,我应该得到这样的东西:
If i click a button/run a macro, I should get something like this :
- 对于所有具有"AU"的行,
- 4个随机行
- 所有具有"FJ"的行的随机行为1
- 所有具有"NC"的行的随机行为1
- 所有具有"NZ"的行的3个随机行
- 所有具有"SG12"的行的随机行为1
- 4 random rows for all rows that has "AU"
- 1 random row for all rows that has "FJ"
- 1 random row for all rows that has "NC"
- 3 random rows for all rows that has "NZ"
- 1 random row for all rows that has "SG12"
从Raw Data_Park Sampling.xlsx
"Sheet1
"表中的所有内容并将其粘贴到Park Sampling Tool.xlsm
"Random Sample
"表中.
ALL FROM Raw Data_Park Sampling.xlsx
"Sheet1
" sheet and paste it to Park Sampling Tool.xlsm
"Random Sample
" sheet.
所有操作都应一键完成.
All should happen in one click.
下面是我得到的全部代码.
Below is the whole code i got.
Sub MAINx1()
'Delete current random sample
Sheets("Random Sample").Select
Cells.Select
Range("C14").Activate
Selection.Delete Shift:=xlUp
Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
Dim map, i As Long, n As Long, c As Long, rand, col
Dim keyArr, nRowsArr
Dim rng As Range
Set rawDataWs = Workbooks("Raw Data_Park Sampling.xlsx").Worksheets("Sheet1")
Set randomSampleWs = Workbooks("Park Sampling Tool.xlsm").Worksheets("Random Sample")
randomSampleWs.UsedRange.ClearContents
'Set map = RowMap(rawDataWs.Range("A2:A923"))
Set rng = rawDataWs.Range("A2:A" & _
rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)
Set map = RowMap(rng)
keyArr = Array("AU", "FJ", "NC", "NZ", "SG12", "ID", "PH26", "PH24", "TH", "ZA", "JP", "MY", "PH", "SG", "VN") '<== keywords
nRowsArr = Array(4, 1, 1, 3, 1, 3, 3, 1, 3, 4, 2, 3, 1, 3, 2) '<== # of random rows
'Debug.Print "Key", "#", "Row#"
For i = LBound(keyArr) To UBound(keyArr)
If map.exists(keyArr(i)) Then
Set col = map(keyArr(i))
n = nRowsArr(i)
For c = 1 To n
'select a random member of the collection
rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")")
'Debug.Print keyArr(i), rand, col(rand)
rawDataWs.Rows(col(rand)).Copy _
randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
col.Remove rand 'remove the "used" row
If col.Count = 0 Then
If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
Exit For
End If
Next c
Else
'Debug.Print "No rows for " & keyArr(i)
End If
Next i
MsgBox "Random Sample: Per Day Successfully Generated!"
End Sub
'get a map of rows as a dictionary where each value is a collection of row numbers
Function RowMap(rng As Range) As Object
Dim dict, c As Range, k
Set dict = CreateObject("scripting.dictionary")
For Each c In rng.Cells
k = Trim(c.value)
If Len(k) > 0 Then
If Not dict.exists(k) Then dict.Add k, New Collection
dict(k).Add c.Row
End If
Next c
Set RowMap = dict
End Function
推荐答案
从原始代码简化为专注于该方法:
Simplified from your original code to focus on the approach:
Sub MAIN()
Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
Dim map, i As Long, n As Long, c As Long, rand, col
Dim keyArr, nRowsArr, rng
Set rawDataWs = Worksheets("Sheet1")
Set randomSampleWs = Worksheets("Sheet2")
randomSampleWs.UsedRange.ClearContents
'EDIT: dynamic range in ColA
Set rng = rawDataWs.Range("A2:A" & _
rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)
Set map = RowMap(rng)
keyArr = Array("AU", "FJ", "NC", "NZ", "SG12") '<== keywords
nRowsArr = Array(4, 1, 1, 3, 10) '<== # of random rows
Debug.Print "Key", "#", "Row#"
For i = LBound(keyArr) To UBound(keyArr)
If map.exists(keyArr(i)) Then
Set col = map(keyArr(i))
n = nRowsArr(i)
For c = 1 To n
'select a random member of the collection
rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")")
Debug.Print keyArr(i), rand, col(rand)
rawDataWs.Rows(col(rand)).Copy _
randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
col.Remove rand 'remove the "used" row
If col.Count = 0 Then
If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
Exit For
End If
Next c
Else
Debug.Print "No rows for " & keyArr(i)
End If
Next i
End Sub
'get a map of rows as a dictionary where each value is a collection of row numbers
Function RowMap(rng As Range) As Object
Dim dict, c As Range, k
Set dict = CreateObject("scripting.dictionary")
For Each c In rng.Cells
k = Trim(c.Value)
If Len(k) > 0 Then
If Not dict.exists(k) Then dict.Add k, New Collection
dict(k).Add c.Row
End If
Next c
Set RowMap = dict
End Function
这篇关于VBA/宏根据多个条件复制随机行的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持!