1

大量のシートを含む Excel ワークブックがあります。最初のシート「ユーザー」には、ユーザーデータ、名、姓、電子メールなどがあります。すべてCSVファイルからきれいに分割されています。他のシートには、いくつかの名前があり、「ユーザー」シートからのメールが必要です。

問題は、他のすべてのシートの名前がす​​べて1つのセルにあり、姓と名の両方が似ており、ユーザーシートでは分割されていることです。また、他のシートでは、「Mike Anderson」、「Mike、Anderson」、または「Anderson、Mike」と書かれている場合もあります。

対応するメールを見つけてコピーするのに役立つマクロ/VBAスクリプト/フォーミュラーのアイデアを持っている人はいますか?

4

3 に答える 3

7

Mike Anderson、Mike, Andersonまたはをチェックするには、とAnderson, Mikeを使用できます。.Find.FindNext

この例を参照してください

ロジック：Excelの組み込み.Findメソッドを使用して検索Mikeし、それが見つかったら、セルにもあるかどうかを確認しますAnderson

Sub Sample()
    Dim oRange As Range, aCell As Range, bCell As Range
    Dim ws As Worksheet
    Dim SearchString As String, FoundAt As String

    On Error GoTo Err

    Set ws = Worksheets("Sheet1")
    Set oRange = ws.Columns(1)

    SearchString = "Mike"

    Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

    If Not aCell Is Nothing Then
        Set bCell = aCell

        If InStr(1, aCell.Value, "Anderson", vbTextCompare) Then _
        FoundAt = aCell.Address

        Do
            Set aCell = oRange.FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                If InStr(1, aCell.Value, "Anderson", vbTextCompare) Then _
                FoundAt = FoundAt & ", " & aCell.Address
            Else
                Exit Do
            End If
        Loop
    Else
        MsgBox SearchString & " not Found"
        Exit Sub
    End If

    MsgBox "The Search String has been found these locations: " & FoundAt
    Exit Sub
Err:
    MsgBox Err.Description
End Sub

スクリーンショット

ここに画像の説明を入力

詳細.Findは.Findnext こちら。

于 2013-04-10T14:35:59.877 に答える
0

検索された値は、ワークブックの最初のシートに追加されたテキスト ボックスとオプション ボタンを使用して、すべてのワークブックで簡単に見つけることができます。

ここに画像の説明を入力

オプション ボタンを介して、テキスト ボックス内の値は、全体または一部の 2 つのタイプとして検索できます。

If Sheets(1).OptionButton1 = True Then
Set Firstcell = Cells.Find(What:=Sheets(1).TxtSearch, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
Else
Set Firstcell = Cells.Find(What:=Sheets(1).TxtSearch, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
End If

私もテンプレートコーディングでFind & FindNext Methodを使用しました:

If Not Firstcell Is Nothing Then
Firstcell.Activate
Firstcell.Interior.ColorIndex = 19

With Sheets("New_Report").Range("A1")
.Value = "Addresses Of The Found Results"
.Interior.ColorIndex = 19
End With
Sheets("New_Report").Range("A:A").EntireColumn.AutoFit
Sheets("New_Report").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = oSheet.Name & "!" & Firstcell.Address(False, False)

Call Create_Hyperlinks  'Hyperlinks are generated in New Report Sheet

If MsgBox("Found " & Chr(34) & Sheets(1).TxtSearch & Chr(34) & " in " & oSheet.Name & "!" & Firstcell.Address & vbLf & "Do You Want To Continue?", vbExclamation + vbYesNo) = vbNo Then
Exit Sub: End If

While (Not NextCell Is Nothing) And (Not NextCell.Address = Firstcell.Address)
                    counter = counter + 1
Firstcell.Interior.ColorIndex = xlNone
Set NextCell = Cells.FindNext(After:=ActiveCell)

If NextCell.Row = 2 Then
Set NextCell = Range(Cells(3, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, LastColumn)).FindNext(After:=ActiveCell)
End If

If Not NextCell.Address = Firstcell.Address Then
NextCell.Activate
NextCell.Interior.ColorIndex = 19
Sheets("New_Report").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = oSheet.Name & "!" & NextCell.Address(False, False)

Call Create_Hyperlinks

If MsgBox("Found " & Chr(34) & Sheets(1).TxtSearch & Chr(34) & " in " & oSheet.Name & "!" & NextCell.Address & vbLf & "Do You Want To Continue?", vbExclamation + vbYesNo) = vbNo Then
Exit Sub: End If

End If 'If Not NextCell.Address = Firstcell.Address Then
NextCell.Interior.ColorIndex = xlNone

Wend
End If
Next oSheet
End If

すべての結果は、生成されたレポート シートにハイパーリンクとして一覧表示され、機能が異なります。

于 2016-07-29T14:56:18.420 に答える