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

好的，这里有几个函数可以用来确定特定标题在哪一列中。一旦有了列和行，就可以使用它来设置目标范围。

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

Answer 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


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

如何修改下面的代码以复制下一个相邻单元格中的值并将其粘贴到工作表2中

2 个答案: