Question

我的Excel VBA编码有问题。

我想让一个编码可以将数据从一张纸复制到具有特定条件的纸张。我的数据是二进制格式。

sheet1中的数据有近千行。我只想从sheet1到sheet 2获取15个随机数据行。必须满足的标准是每列只有列的总和为3.如果不满足，则将采用其他数据。

当我点击生成时。它将从数据表1复制到表2.我希望我的数据副本像红色圆圈一样。不喜欢红柱一个。请帮帮我

Option Explicit
Sub Random20()
Randomize
Dim MyRows() As Integer    
Dim numRows, percRows, nxtRow, nxtRnd, chkRnd, copyRow As Integer
'Determine Number of Rows in Sheet1 Column A
  numRows = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

   percRows = 17

    ReDim MyRows(percRows) 
'Create Random numbers and fill array
     For nxtRow = 1 To percRows
getNew:
'Generate Random number
      nxtRnd = Int((numRows) * Rnd + 1)
'Loop through array, checking for Duplicates
       For chkRnd = 1 To nxtRow
'Get new number if Duplicate is found
        If MyRows(chkRnd) = nxtRnd Then GoTo getNew
       Next
'Add element if Random number is unique
      MyRows(nxtRow) = nxtRnd
     Next
'Loop through Array, copying rows to Sheet2
  For copyRow = 1 To percRows
   Sheets(1).Rows(MyRows(copyRow)).EntireRow.Copy _
     Destination:=Sheets(2).Cells(copyRow, 1)
  Next
End Sub

Answer 1

这将实现您的目标，但代码需要很长时间才能执行，我实际上使用RANDBETWEEN(1,COUNTIF(Sheet1!A:A,"<>"&""))和RandBetweenInt(1,COUNTIF(Sheet1!A:A,"<>"&""),***Range of Random Integers from above***)（用户定义的函数找到{模拟了代码来模拟您的代码） {3}}）。这计算得更快，并且不包括重复的随机数字。

Sub chkRand()

Application.Calculation = xlCalculationManual

Do Until Worksheets("Sheet3").Range("I18").Value = 1
Application.Calculate
Loop

End Sub

.Range("I18")具有公式=IF(COUNTIF(B18:H18,3)=7,1,0)，因此这将强制手动计算，然后重新计算，直到所有列总数为3。

要小心，虽然我已经让这个宏运行了30分钟，但它仍然没有找到匹配。

如果您真的在寻找我将使用的仅限VBA的解决方案：

For Clm = 2 To 8
ClmTtl = 0
    For copyRow = 1 To percRows
     ClmTtl = ClmTtl + Sheets(1).Cells(MyRows(copyRow), clm).Value
    Next
    If Not ClmTtl = 3 Then Call Random20
Next

虽然我总是建议首先寻找基于公式的解决方案，但只在需要的地方使用宏。

由于这只能在前一个总计为3的情况下进入下一列，所以代码只能在它们全部具有所需总数时才能完成。希望这会有所帮助，祝你好运，减少运行时间。

复制并粘贴到vba中

1 个答案: