我需要帮助才能从具有特定条件的其他工作簿中获取随机行：
如果我点击一个按钮/运行一个宏，我应该得到这样的东西：
全部来自Raw Data_Park Sampling.xlsx＆＃34; Sheet1＆＃34;将其打印并粘贴到Park Sampling Tool.xlsm＆＃34; Random Sample＆＃34;片材。
只需点击一下即可完成。
以下是我得到的整个代码。
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
答案 0 :(得分：1)
从原始代码中简化以专注于该方法：
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
答案 1 :(得分：0)
不确定我是否可以遵循逻辑，因为它对我来说太复杂了。如果你不介意，我会制定一个替代代码。
编辑： 我假设您可以修改代码以获取源/目标。我在excel 2013中测试了这个并假设：
您将根据您的要求修改oKey和oCnt。
Dim oWS As Worksheet
Dim oWSSrc As Worksheet
Dim oWBSrc As Workbook
Dim oWBDest As Workbook
Dim oRng As Range
Dim oStart As Range
Dim oLast As Range
Dim oMatch As Range
Dim oDest As Range
Dim oKey As Variant
Dim oCnt As Variant
Dim iCnt As Integer
Dim iTot As Integer
Dim iMatch As Integer
oKey = Split("AU,FJ,NZ", ",") '<= modify this
oCnt = Split("4,1,3", ",") ' <= modify this
'Open Destination
Set oWBDest = Application.Workbooks.Open("Tool.xlsm")
Set oWS = oWBDest.Sheets.Add
'Open source workbook
Set oWBSrc = Application.Workbooks.Open("Rawdata.xlsx")
Set oWSSrc = oWBSrc.Sheets("Sheet1")
Set oRng = oWSSrc.Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown))
oRng.Copy oWS.Cells(1, 1)
oWBSrc.Close
'assume key
Set oStart = oWS.Cells(1, 1)
Set oRng = oWS.Range(oStart, oStart.End(xlToRight).End(xlDown).Offset(1))
oWBDest.Sheets("Random Sample").UsedRange.Clear
Set oDest = oWBDest.Sheets("Random Sample").Cells(1, 1)
Randomize
'Assign random numbers for sorting
For iCnt = 1 To oRng.Rows.Count - 1 ' last row is a dummy row do not assign
oRng.Cells(iCnt, oRng.Columns.Count + 1) = Rnd()
Next
'sort by key (col1) and random number (last col)
With oWS.Sort
.SortFields.Clear
.SortFields.Add oWS.Columns(1)
.SortFields.Add oWS.Columns(oRng.Columns.Count + 1)
.SetRange oWS.Range(oStart, oStart.End(xlToRight).End(xlDown))
.Apply
End With
For iCnt = LBound(oKey) To UBound(oKey)
'Find the first match
Set oStart = oRng.Find(oKey(iCnt), oRng.Cells(oRng.Rows.Count, 1), xlValues, xlWhole, xlByRows, xlNext)
Set oLast = oStart ' initiliase
If Not oStart Is Nothing Then
'-1 as the first one has been detected
For iMatch = 1 To CInt(oCnt(iCnt)) - 1
Set oMatch = oRng.Find(oKey(iCnt), oLast, xlValues, xlWhole, xlByRows, xlNext)
' Match the same as start exit (means there are not enough row)
If oMatch.Address = oStart.Address Then
Exit For
Else
Set oLast = oMatch
End If
Next
'copy the match to output
Set oStart = oWS.Range(oStart, oLast.Offset(, oRng.Columns.Count - 1))
oStart.Copy oDest
If oDest.Offset(1).Value <> "" Then
Set oDest = oDest.End(xlDown).Offset(1)
Else
Set oDest = oDest.Offset(1)
End If
End If
Next
'Cleaning up
Application.DisplayAlerts = False
oWS.Delete
Application.DisplayAlerts = True
oWBDest.Save
oWBDest.Close