Как изменить приведенный ниже код, чтобы скопировать значение из следующей соседней ячейки и вставить его в лист 2

Question

Я новый ученик Excel VBA. Помогите изменить приведенный ниже код, чтобы скопировать значение из следующей соседней ячейки, поскольку этот код копирует значение из того же столбца и ячеек

Public Sub FindSales()

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

    sValToFind = InputBox("Please enter Sales Order No.")
    '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 & ", "

                'Create a range of found cells.
                If Not rAllFoundCells Is Nothing Then
                    Set rAllFoundCells = Union(rAllFoundCells, rFoundCell)
                Else
                    Set rAllFoundCells = rFoundCell
                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

Answer 1

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


ThisWorkbook.Worksheets("Sheet2").Range("A1").Select
Selection.End(xlToRight).Select
my_row = Selection.Column



For i = 1 To my_row



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

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)

            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").Cells(2, i)
Set rSearchRange = Null
Set rFoundCell = Null
Set NextFoundCell = Null
Set rAllFoundCells = Null



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

Next i


End Sub

Answer 2

ОК, вот пара функций, которые вы можете использовать, чтобы определить, в каком столбце находится конкретный заголовок. Получив столбец и строку, вы можете использовать их для установки целевого диапазона.

Function Find_Column_Heading(ByRef shTarget As Worksheet, ByVal myHeading As String) As Long
'search row 1 of shTarget for a specific heading and return the column number
Dim intMaxCol As Long, intColCount As Long, varFindCell As Variant, rngToLookIn As Range
intMaxCol = shTarget.Cells(1, shTarget.Columns.Count).End(xlToLeft).Column
Set rngToLookIn = shTarget.Range(shTarget.Cells(1, 1), shTarget.Cells(1, intMaxCol))
Set varFindCell = rngToLookIn.find(what:=myHeading, after:=shTarget.Cells(1, 1), lookat:=xlWhole, LookIn:=xlValues)
If Not varFindCell Is Nothing Then
    Find_Column_Heading = varFindCell.Column
Else
    Find_Column_Heading = intMaxCol + 1
End If
End Function


Function Find_Bottom_Row(ByRef shTarget As Worksheet, intColumn As Long) As Long
'this will return the row of the empty cell below the lowest used cell in the specified column
Find_Bottom_Row = shTarget.Cells(shTarget.Rows.Count, intColumn).End(xlUp).Row + 1
End Function



Dim rFoundCell As Range, NextFoundCell As Range 'Add a new variable


Set NextFoundCell = rFoundCell.Offset(0, 1) 'this selects the cell to the right of the search target

'Create a range of found cells.
If Not rAllFoundCells Is Nothing Then
    Set rAllFoundCells = Union(rAllFoundCells, NextFoundCell) 'add the cell to the right to the result range
Else
    Set rAllFoundCells = NextFoundCell
End If