Question

是否可以在第1行（标题）中搜索由另一张表格定义的值？我需要＆＃34; FName＆＃34;与单个单元格相对应的列或值范围。

以下是我迄今为止能够开展工作的示例：

 FName = Workbooks("IntChk.xlsm").Worksheets("Data").Range("B3")

 Set rngFound = Worksheets("File").Rows(1).Find(What:=FName, LookIn:=xlValues, LookAt:=xlWhole, _
     SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

Answer 1

在从其他工作簿中识别搜索词后，您希望在此工作簿的第1行中找到一个或多个匹配项（...？）并记录与匹配项对应的列。

Option Explicit

Sub get_em_all()
    Dim fName As String, addr As String
    Dim rng As Range, fnd As Range

    'get search criteria
    fName = Workbooks("IntChk.xlsm").Worksheets("Data").Range("B3")

    With ThisWorkbook   '<~~ different from IntChk.xlsm...?
        With .Worksheets("File").Rows(1)
            'perform first search
            Set fnd = .Rows(1).Find(What:=fName, MatchCase:=False, _
                                    LookIn:=xlValues, LookAt:=xlWhole)
            'was anything found
            If Not fnd Is Nothing Then
                'record the first find
                Set rng = fnd
                addr = rng.Address
                'loop and collect results until we arrive at the first find
                Do
                    Set rng = Union(rng, fnd)
                    Set fnd = .FindNext(after:=fnd)
                Loop Until addr = fnd.Address

                'expand the found cells from the first row to the columns within the current region
                With .Parent.Cells(1, 1).CurrentRegion
                    Set rng = Intersect(rng.EntireColumn, .Cells)
                End With

                'report the address(es) of the cell(s) found
                Debug.Print rng.Address(0, 0)

            Else
                Debug.Print 'nothing found"
            End If
        End With
    End With

End Sub

Answer 2

已修改以更正某些＆＃34;优化＆＃34;错别字

我认为你想要选择一个＆＃34;标题＆＃34;排列其值在另一个范围内的所有单元格

如果这是您的目标，您可以尝试以下

Option Explicit

Function GetRange(fnameRng As Range, dataRng As Range) As Range
Dim fName As String

'get search criteria
fName = GetJoinFromRange(fnameRng)
With dataRng
    .Rows(1).Insert
    With .Offset(-1).Resize(1)
        .FormulaR1C1 = "=if(isnumber(search(""-"" & R2C & ""-"" ,""" & fName & """)),1,"""")"
        .Value = .Value
        Set GetRange = .SpecialCells(xlCellTypeConstants)).Offset(1)
    End With
    .Rows(1).Offset(-1).EntireRow.Delete
End With

End Function


Function GetJoinFromRange(rng As Range) As String
If rng.Rows.Count > 1 Then
    GetJoinFromRange = "-" & Join(Application.Transpose(rng), "-") & "-"
Else
    GetJoinFromRange = "-" & Join(rng, "-") & "-"
End If
End Function

可以被＆＃34; main＆＃34; sub like follow

Option Explicit

Sub main()
Dim fnameRng As Range, dataRng As Range, rngFound As Range

Set fnameRng = Workbooks("IntChk.xlsm").Worksheets("Data").Range("B3:B6") '<== adapt it to your needs
Set dataRng = ThisWorkbook.Worksheets("File").Range("B1:I1000") '<== adapt it to your needs

Set rngFound = GetRange(fnameRng, dataRng)

End Sub

Answer 3

经过一周的反复试验，我能够创建此代码。它运作良好，光线充足。

sub IntChk
Dim i As Integer
Lastcol = 5
For i = 1 To 1
For j = 1 To Lastcol
MsgBox "Cell Value = " & Cells(j) & vbNewLine & "Column Number = " & j
    For Each c In Workbooks("IntChk.xlsm").Worksheets("Data").Range("A1:A50")
        If c.Value = Cells(j) Then
        MsgBox "Match"
        Match = "True"
        End If
    Next c
Next j    
If Match = "True" Then
MsgBox "Yes, True!"
Else:
MsgBox "not true ;("
End If
Next I
end sub

搜索列标题标签值

3 个答案: