我的剧本行为不当

Question

我有一个脚本可以在A列中搜索＆＃39; Assay＆＃39;并复制（0,2）并将其粘贴到每行的末尾，直到有一个空行。这适用于我的大多数团队，但特别是一个团队的行为不当。

它按预期复制单元格，只将其粘贴到前两行。我不知道如何纠正它。

这是我的数据的屏幕截图：

以下是我正在使用的代码。我觉得它与行中有空白有关，但我不知道如何更正脚本。

Sub AddDescriptive()
  Dim Assays as Range, Assay As Range, Group As Range, P As Range
  Set Assays = FindAll(Columns("A"),"Assay")
  If Assays Is Nothing Then
     Exit Sub
  End If

  'Visit each
  For Each Assay In Assays
  'Get the group
  Set Group = Assay.Offset(, 2)
  'Assign to column P
  Set P = Intersect(Assay.CurrentRegion.EntireRow, Columns("P"))
  'Write the group into column P
  P.Value = Group.Value
 Next
End Sub

Function FindAll(ByVal Where As Range, ByVal What, _
     Optional ByVal After As Variant, _
     Optional ByVal LookIn As XlFindLookIn = xlValues, _
     Optional ByVal LookAt As XlLookAt = xlWhole, _
     Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
     Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
     Optional ByVal MatchCase As Boolean = False, _
     Optional ByVal SearchFormat As Boolean = False) As Range
 'Find all occurrences of What in Where (Windows version)
  Dim FirstAddress As String
  Dim c As Range
 'From FastUnion:
  Dim Stack As New Collection
  Dim Temp() As Range, Item
  Dim i As Long, j As Long

 If Where Is Nothing Then Exit Function
 If SearchDirection = xlNext And IsMissing(After) Then
 'Set After to the last cell in Where to return the first cell in Where in 
   front if it match What
 Set c = Where.Areas(Where.Areas.Count)
'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
'Set After = C.Cells(C.Cells.Count)
 Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count))
End If
 Set c = Where.find(What, After, LookIn, LookAt, SearchOrder, _
 SearchDirection, MatchCase, SearchFormat:=SearchFormat)
 If c Is Nothing Then Exit Function
 FirstAddress = c.Address
 Do
 Stack.Add c
 If SearchFormat Then
  'If you call this function from an UDF and _
    you find only the first cell use this instead
 Set c = Where.find(What, c, LookIn, LookAt, SearchOrder, _
    SearchDirection, MatchCase, SearchFormat:=SearchFormat)
Else
  If SearchDirection = xlNext Then
    Set c = Where.FindNext(c)
  Else
    Set c = Where.FindPrevious(c)
  End If
End If
'Can happen if we have merged cells
If c Is Nothing Then Exit Do
Loop Until FirstAddress = c.Address
'FastUnion algorithm © Andreas Killer, 2011:
'Get all cells as fragments
 ReDim Temp(0 To Stack.Count - 1)
 i = 0
 For Each Item In Stack
 Set Temp(i) = Item
 i = i + 1

Next
'Combine each fragment with the next one
j = 1
Do
For i = 0 To UBound(Temp) - j Step j * 2
  Set Temp(i) = Union(Temp(i), Temp(i + j))
Next
j = j * 2
Loop Until j > UBound(Temp)
'At this point we have all cells in the first fragment
Set FindAll = Temp(0)
End Function

Answer 1

问题不在于FindAll。 （它只是返回包含A列中包含文本"Assay"的单元格的范围，因此可能会返回范围$A$2,$A$345,$A$1235,$A$1365。）

您的问题实际上是使用Assay.CurrentRegion，它将只返回包含Assay引用的单元格的当前区域，并且该区域的大小只有两行四列。 / p>

根据屏幕截图中的数据，您似乎希望将值"APPEARANCE"放入P列，从找到"Assay"的行开始，到结束前的行。 N列中的下一个空白单元格。

这可以通过改变

来实现

  Set P = Intersect(Assay.CurrentRegion.EntireRow, Columns("P"))

是

  Set P = Range("P" & Assay.Row & ":P" & Range("N" & (Assay.Row + 1)).End(xlDown).Row)