Question

所以我的工作簿上有名为Contacts和Help的工作表。在帮助表中，我有一个按钮，显示输入框并询问＆＃34;您想要找到哪个客户？＆＃34;
当我输入像Samuel Smith这样的名字时。我希望VBA能够转到联系表，然后找到我Samuel Smith并向右侧偏移一个专栏并复制Samuel Smith工作的公司。然后将其粘贴到帮助表，找到下一个塞缪尔史密斯。即使在联系人中有50位塞缪尔·史密斯，我也愿意这样做！只是不知道如何做到这一点所以非常感谢任何帮助！

提前谢谢大家的回答。

Answer 1

下面是我的自定义函数，可以在Array中找到并返回结果。

从查找结果中，您应该能够解决问题。

希望这有帮助！

Sub test()
'The result will be on Column C, because offset = 1
Dim nItem, Found As Variant

Found = iFind("Concatenate", Columns(2), 1)

  For Each nItem In Found
      MsgBox nItem
  Next

End Sub


Function iFind(ByVal findText As String, ByVal nColumn As Range, ByVal offsetColumn As Single, _
                Optional ByVal startRow As Single = 1, Optional ByVal caseSensitive As Boolean = False) As Variant
'Return Array of Range
'nColumn - Column to find
'offsetColumn - offset column to return

Dim WBD As Workbook
Dim WSD As Worksheet
Dim lastRow, tCount, nCount, nRow, nCol, N As Single
Dim nColRng, dataRng As Range
Dim compare As VbCompareMethod
Dim nArray As Variant
ReDim nArray(0)

    Set WSD = nColumn.Parent

    'Ensure only on column selected to consider lastRow
    Set nColRng = nColumn.Columns(1)
    nCol = nColRng.Column

    'Get the lastRow
    On Error Resume Next
        lastRow = startRow
        lastRow = nColRng.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If lastRow < startRow Then lastRow = startRow
    On Error GoTo 0

    Set dataRng = Intersect(WSD.Range(WSD.Rows(startRow), WSD.Rows(lastRow)), nColRng)

    tCount = Excel.Application.WorksheetFunction.CountIfs(dataRng, findText)
    If tCount > 0 Then
        nCount = 0
        N = 0
        Do While nCount < tCount
            nRow = Excel.Application.Match(findText, dataRng, 0) + dataRng(1).Row - 1
            If caseSensitive = True Then
                compare = vbBinaryCompare
            Else
                compare = vbTextCompare
            End If

            'Add into array, only if matching case
            If InStr(1, findText, WSD.Cells(nRow, nCol), compare) Then
                ReDim Preserve nArray(N)
                nArray(N) = WSD.Cells(nRow, nCol + offsetColumn)
                N = N + 1
            End If

            nCount = nCount + 1
            'Resize dataRng
            Set dataRng = Intersect(WSD.Range(WSD.Rows(nRow + 1), WSD.Rows(lastRow)), nColRng)
        Loop
    End If

    iFind = nArray
End Function

Answer 2

我在这个洞的夜晚工作，现在我知道怎么做了！

class

功能

Option Explicit
'''''''
Dim Find_Inp As String
Dim Find As Variant
Dim Error_ As Integer
'''''''

Sub Test2()
On Error Resume Next

Sheet1.Select
Range("A8:G100").ClearContents

Find_Inp = InputBox("Please input Account!")
If Find_Inp = "" Then
    Exit Sub
End If

MsgBox "This will take some time please wait."
Sheet2.Select
Call Macro1 'Sort macro

Call Find_Full
Exit Sub

End Sub

排序宏

Private Function Find_Full()
On Error GoTo ErrorHandler
'''''''
Dim Account_Column As Variant
Dim Result As Range, Result2 As Range
Dim LastAccount As Long
Dim NextAccount As Long
Dim Find_repeat As Integer
'''''''

Sheets("Contacts").Select
Account_Column = Range("G1").Select


Find = Cells.Find(What:=Find_Inp, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
Find_repeat:

If Find = True Then
Set Result = ActiveCell

    LastAccount = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
    NextAccount = LastAccount + 1

    Result.Copy 'Where the name
    Sheet1.Select
    Range("C" & NextAccount).PasteSpecial xlPasteValuesAndNumberFormats

    Result.Offset(0, -2).Copy   'Where the firm name is
    Sheet1.Select
    Range("C" & NextAccount).Offset(0, 1).PasteSpecial xlPasteValuesAndNumberFormats

    Sheet2.Select
    Result.Offset(0, -1).Copy   'Where the email is
    Sheet1.Select
    Range("C" & NextAccount).Offset(0, 2).PasteSpecial xlPasteValuesAndNumberFormats

    Sheet2.Select
    Result.Offset(0, 9).Copy    'Where the phone number
    Sheet1.Select
    Range("C" & NextAccount).Offset(0, -2).PasteSpecial xlPasteValuesAndNumberFormats

    Sheet2.Select
    Result.Offset(0, 10).Copy   'Where the work number is
    Sheet1.Select
    Range("C" & NextAccount).Offset(0, -1).PasteSpecial xlPasteValuesAndNumberFormats

    Sheet2.Select
    Result.Offset(0, 4).Copy    'Where the firm addres is
    Sheet1.Select
    Range("C" & NextAccount).Offset(0, 3).PasteSpecial xlPasteValuesAndNumberFormats

    Sheet2.Select
    Result.Offset(0, 5).Copy    'Where the title is
    Sheet1.Select
    Range("C" & NextAccount).Offset(0, 4).PasteSpecial xlPasteValuesAndNumberFormats

    Error_ = 0

End If

Sheet2.Select
Result.Offset(1, 0).Select
Set Result2 = ActiveCell

If Result2 = Find_Inp Then
    GoTo Find_repeat
Else
    Sheet1.Select
    Range("A1").Select
End If

ErrorHandler:

If Error_ = 1 Then
    Sheet1.Select
    Range("A1").Select
    MsgBox "Account was not found! Try again."
End If

Error_ = 1

End Function

如何使用VBA在工作表中查找数据？

2 个答案: