Необходимо сопоставить заголовки столбцов и скопировать данные на листе 2

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 -блоке.Как ни странно, вы копируете некоторые результаты обратно в область поиска значений!Но все равно:

    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