Question

由于我有限的VBA知识，我几天来一直在尝试解决此问题。我还搜索了几个论坛和Google，以获得所需的解决方案，但无济于事。

请帮助修改以下代码，以找到与工作表2中所有列标题匹配的值，并将找到的值粘贴到每列下方。

代码：

Public Sub FindVa()

    Dim sValToFind As String
    Dim rSearchRange As Range
    Dim sFirstAdd As String
    Dim rFoundCell As Range, NextFoundCell As Range
    Dim rAllFoundCells As Range
    Dim sMessage As String


    sValToFind = ThisWorkbook.Worksheets("Sheet2").Range("A1")
    'Code to check a valid number entered
    '.
    '.

    With ThisWorkbook.Worksheets("Sheet1")
        Set rSearchRange = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With

    With rSearchRange
         Set rFoundCell = .Find(sValToFind, LookIn:=xlValues, LookAt:=xlPart)
         If Not rFoundCell Is Nothing Then
            sFirstAdd = rFoundCell.Address
            Do

                sMessage = sMessage & rFoundCell.Row & ", "
                Set NextFoundCell = rFoundCell.Offset(0, 1)
                'Create a range of found cells.
                If Not rAllFoundCells Is Nothing Then
                    Set rAllFoundCells = Union(rAllFoundCells, NextFoundCell)
                Else
                    Set rAllFoundCells = NextFoundCell
                End If
                Set rFoundCell = .FindNext(rFoundCell)
            Loop While rFoundCell.Address <> sFirstAdd
         End If
    End With

    rAllFoundCells.Copy Destination:=ThisWorkbook.Worksheets("Sheet2").Range("A1")

    sMessage = sValToFind & " found on rows " & Mid(sMessage, 1, Len(sMessage) - 2) & "."
    MsgBox sMessage, vbOKOnly + vbInformation

End Sub

请帮助修改上面的代码，以找到与工作表2中的“列”标题匹配的值，并将找到的值粘贴到每列下面。预先感谢

Answer 1

这是在所有列中运行的代码，直到找到一个空单元格或到达工作表的末尾，尽管我不完全了解您在With rsEarchRange-Block中的操作。奇怪的是，您将一些结果复制回搜索值区域！但是无论如何：

    Option Explicit

    Public Sub FindVa()

        Dim sValToFind As String
        Dim rSearchRange As Range
        Dim sFirstAdd As String
        Dim rFoundCell As Range, NextFoundCell As Range
        Dim rAllFoundCells As Range
        Dim sMessage As String
        Dim columnNo As Integer
        Dim SearchSheet As Worksheet

        Set SearchSheet = ThisWorkbook.Worksheets("Sheet1")
        columnNo = 1

        Do
            ' Check for Column Overflow
            If columnNo > SearchSheet.Columns.Count Then Exit Sub
            ' Check for empty cell
            If SearchSheet.Cells(1, columnNo) = "" Then Exit Sub
            ' (Usually, I would have writte Do While ... and ..., but you would
            ' eventually run into an error.

            sValToFind = ThisWorkbook.Worksheets("Sheet2").Cells(1, columnNo)

            'Code to check a valid number entered
            '.
            '.

            With SearchSheet
                Set rSearchRange = .Range(.Cells(1, columnNo), .Cells(.Rows.Count, columnNo).End(xlUp))
            End With
            Set rAllFoundCells = Nothing
            sMessage = ""
            With rSearchRange
                 Set rFoundCell = .Find(sValToFind, LookIn:=xlValues, LookAt:=xlPart)
                 If Not rFoundCell Is Nothing Then
                    sFirstAdd = rFoundCell.Address
                    Do

                        sMessage = sMessage & rFoundCell.Row & ", "
                        Set NextFoundCell = rFoundCell.Offset(0, 1)
                        'Create a range of found cells.
                        If Not rAllFoundCells Is Nothing Then
                            Set rAllFoundCells = Union(rAllFoundCells, NextFoundCell)
                        Else
                            Set rAllFoundCells = NextFoundCell
                        End If
                        Set rFoundCell = .FindNext(rFoundCell)
                    Loop While rFoundCell.Address <> sFirstAdd
                 End If
            End With

            If Not rAllFoundCells Is Nothing Then
                rAllFoundCells.Copy Destination:=ThisWorkbook.Worksheets("Sheet2").Cells(1, columnNo)

                sMessage = sValToFind & " found on rows " & Mid(sMessage, 1, Len(sMessage) - 2) & "."
            Else
                sMessage = sValToFind & " not found."
            End If

            MsgBox sMessage, vbOKOnly + vbInformation

            columnNo = columnNo + 1
        Loop
    End Sub

需要在表2中匹配列标题并复制数据

1 个答案: