excel VBA 的 FIndAll 函数（使用 cPearson）代码

Question

尝试根据找到的单个值来查找一系列单元格值，然后将这些值插入到评论中。我的代码基于单个查找值（感谢之前的 Whosebug post），但我似乎无法找到多个值作为一个范围。（即使值正确，也会收到 "Not Found" 消息框）

这是我到达运行但没有找到我的参考值的代码...

这是基于 cPearson 的 FindAll 函数和代码，我无法理解它...请让我知道您需要哪些额外信息来帮助我，感谢您的时间和考虑！

Function FindAll(SearchRange As Range, _
                FindWhat As Variant, _
                Optional LookIn As XlFindLookIn = xlValues, _
                Optional LookAt As XlLookAt = xlWhole, _
                Optional SearchOrder As XlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean = False, _
                Optional BeginsWith As String = vbNullString, _
                Optional EndsWith As String = vbNullString, _
                Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range

                End Function
Sub AddCommentAsDomainDescrReference2()
'Posted by Jeff Barrett 2015-04-10

    Dim sCommentText1 As String
    Dim str1 As String
    Dim cmmt As String
    Dim i As Integer
    Dim SearchRange As Range
    Dim FindString1 As Variant
    Dim Rng1 As Range
    Dim FoundCell As Range

    str1 = "Domain Description: "

 'Loop Code, must specify range for i based on # of FieldDomainName

Sheets("Fields").Select
Range("K4").Select
For i = 4 To 59

    'Find DomainDescription in Domains based on Value from FieldDomainName
    FindString1 = ActiveCell.Value
    'Skip Empty Cells
    If FindString1 = "" Then GoTo Skip
    If Trim(FindString1) <> "" Then
    Set SearchRange = Sheets("Domains").Range("C:C")
            Set Rng1 = FindAll(SearchRange:=Sheets("Domains").Range("C:C"), _
                            FindWhat:=FindString1, _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByColumns, _
                            MatchCase:=False, _
                            BeginsWith:=vbNullString, _
                            EndsWith:=vbNullString, _
                            BeginEndCompare:=vbTextCompare)
    End If

            'Remove any existing comments, create comment and add text in FieldDomainName
            If Not Rng1 Is Nothing Then
                ActiveCell.ClearComments
                sCommentText1 = Rng1.Offset(0, 3).Value
                ActiveCell.AddComment.Text Text:=str1 & Chr(10) & Chr(10) & sCommentText1
                ActiveCell.Comment.Visible = False
                ActiveCell.Comment.Shape.AutoShapeType = msoShapeRoundedRectangle

                'Format lines of text
                    With ActiveCell.Comment.Shape.TextFrame
                            .Characters.Font.ColorIndex = 3

                    End With
                Else
                MsgBox "Nothing found"
            End If
Skip:
'End Loop
ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
Next i

  'Resize Comment to fit text
  'posted by Dana DeLouis  2000-09-16
  Dim MyComments As Comment
  Dim lArea As Long
  For Each MyComments In ActiveSheet.Comments
    With MyComments
      .Shape.TextFrame.AutoSize = True
      If .Shape.Width > 300 Then
        lArea = .Shape.Width * .Shape.Height
        .Shape.Width = 300
        ' An adjustment factor of 1.1 seems to work ok.
        .Shape.Height = (lArea / 200) * 0.6
      End If
    End With
  Next ' comment

End Sub

Answer 1

我最终使用循环来解决我的挑战，而不是尝试使 FindAll 函数工作。下面是代码：

Sub AddCmntWDomainsFINAL()
'Posted by Jeff Barrett 2015-04-10

    Dim FindString1 As String
    Dim Rng1 As Range
    Dim FirstCell As String
    Dim sCommentText1 As String
    Dim cmmt As String
    Dim Msg As String
    Dim i As Integer
    Dim K As Long
    Dim L As Long
    Dim wbk1 As Workbook
    Set wbk1 = Workbooks.Open("My Workbook1")
    Dim wbk2 As Workbook
    Set wbk2 = Workbooks.Open("My Workbook2")

 'Loop Code, must specify range for i based on # of FieldDomainName

wbk2.Sheets("ETHN").Select
Range("L4").Select
For i = 4 To 15

    'Find DomainDescription in Domains based on Value from FieldDomainName
    FindString1 = ActiveCell.Value
    'Skip Empty Cells
    If FindString1 = "" Then GoTo Skip
    If Trim(FindString1) <> "" Then
            With wbk1.Sheets("HG Concepts v6.2").Range("R:R")
                    Set Rng1 = .Find(what:=FindString1, _
                                after:=.Cells(.Cells.Count), _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)
                    'Remove any existing comments, create comment and add text in FieldDomainName
                    'Posted by Darren Bartrup-Cook 2015-04-08
                    If Not Rng1 Is Nothing Then FirstCell = Rng1.Address
                        Do While Not Rng1 Is Nothing
                            If ActiveCell.Comment Is Nothing Then
                                ActiveCell.ClearComments
                                    Msg = Environ("Domain Values: ") _
                                        & "Domain Values: " & vbLf & vbLf _
                                        & "Other"
                                ActiveCell.AddComment Msg
                                ActiveCell.Comment.Visible = False
                                ActiveCell.Comment.Shape.AutoShapeType = msoShapeRoundedRectangle
                                ActiveCell.Comment.Shape.TextFrame.AutoSize = True
                                ActiveCell.Comment.Shape.Width = 150
                                ActiveCell.Comment.Shape.Height = 250
                            Else
                                sCommentText1 = Rng1.Offset(0, 6).Value
                                ActiveCell.Comment.Text Text:=ActiveCell.Comment.Text & vbLf & sCommentText1
                                    With wbk1.Sheets("HG Concepts v6.2").Range("R:R")
                                        Set Rng1 = .FindNext(Rng1)
                                    End With
                                'Format lines of text
                                    With ActiveCell.Comment.Shape.TextFrame
                                            .Characters.Font.ColorIndex = 3
                                            L = Len("Domain Values: ")
                                            K = InStr(1, Msg, "Domain Values: ")
                                              .Characters(K, L).Font.Bold = True
                                              .Characters(K + L, Len("Domain Values: ") - (K + L + 1)).Font.Bold = False
                                    End With
                                If Not Rng1 Is Nothing Then
                                    If Rng1.Address = FirstCell Then Exit Do
                                End If
                            End If
                        Loop
            End With
    End If
Skip:
'End Loop
ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
Next i

End Sub

excel VBA 的 FIndAll 函数（使用 cPearson）代码

FIndAll function for excel VBA (using cPearson) code

excel

vba

findall