复制下一个单元格并粘贴到同一个单元格上

Question

我一直在使用下面的代码来复制下一个单元格并每次粘贴到同一个单元格上。

让我解释一下。 例如 Sheet1 在Range("L1:L" & lastrow)中有值或更多值，如果 range("E4") 为空，我将运行代码，然后 L1 值将在 E4 中更新

然后再次运行代码，现在 L2 值将在 E4 中更新。 然后再次运行代码，现在 L3 值将在 E4 中更新。 然后再次运行代码，现在 L4 值将在 E4 中更新。 等等。

如果 L4 具有最后一个值，则退出 sub，如下代码正在运行。

有没有最简单的方法来做到这一点。 期待您的帮助。

Dim sht1 As Worksheet
Set sht1 = Sheet1

Dim r As Range
Set r = Range(sht1.Cells(1, 12), sht1.Cells(1, 12).End(xlDown))

Dim offset_row As Variant

If IsEmpty(sht1.Cells(4, 5).Value) Then
  offset_row = 0
Else
  offset_row = Application.WorksheetFunction.Match(sht1.Cells(4, 5).Value, r, 0)
End If

If Not IsError(offset_row) Then
  If offset_row <> r.Rows.Count Then
    sht1.Cells(1, 12).Offset(offset_row, 0).copy Destination:=sht1.Cells(4, 5)
  End If
End If

Answer 1

请尝试下一个代码：

Sub FillNextCellVal()
 Dim sht1 As Worksheet, lastR As Long, rng As Range
 Dim ECell As Range, cExist As Range, i As Long
 
 Set sht1 = Sheet1
 Set ECell = sht1.Range("E4")
 lastR = sht1.Range("L" & sht1.rows.count).End(xlUp).row
 Set rng = sht1.Range("L1:L" & lastR)
 
 If ECell.value = "" Then
    ECell.value = rng.SpecialCells(xlCellTypeConstants).Areas(1).value
 Else
    Set cExist = rng.Find(What:=ECell.value, After:=rng.cells(1), _
              LookAt:=xlWhole, LookIn:=xlValues, SearchOrder:=xlByRows)
    If Not cExist Is Nothing Then
        For i = 1 To lastR - cExist.row
            If cExist.Offset(i).value <> "" Then
                ECell.value = cExist.Offset(i).value
                Exit For
            End If
        Next i
    End If
 End If
End Sub

Answer 2

写入下一个单元格值

• 请注意Application.WorksheetFunction.Match或WorksheetFunction.Match是相同的，如果未找到该值，则会发生错误，即您对错误值的测试无效（不会发生）。 它应该用On Error处理。
• 另一方面， Application.Match将产生一个数字或一个错误值，并且可以使用IsError或IsNumeric进行测试。

编码

Option Explicit

Sub writeNextCellValue()
    
    Const dCellAddress As String = "E4"
    Const sFirstCellAddress As String = "L1"
    
    Dim srg As Range ' Source Column Range
    Dim dCell As Range ' Destination Cell Range
    Dim isSourceColumnRangeValid As Boolean ' Source Column Range Validator
    
    With Sheet1.Range(sFirstCellAddress)
        Set srg = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not srg Is Nothing Then
            Set srg = .Resize(srg.Row - .Row + 1)
            isSourceColumnRangeValid = True
            Set dCell = .Worksheet.Range(dCellAddress)
        End If
    End With
    
    If isSourceColumnRangeValid Then
        If dCell.Value = "" Then ' Value is "".
            dCell.Value = srg.Cells(1).Value
        Else ' Value is not "".
            Dim cIndex As Variant
            cIndex = Application.Match(dCell.Value, srg, 0)
            If IsNumeric(cIndex) Then ' Value found.
                If cIndex = srg.Rows.Count Then ' Last value found.
                    'dCell.Value = ""
                    'dCell.Value = srg.Cells(1).Value
                Else ' Not last value found.
                    dCell.Value = srg.Cells(cIndex + 1)
                End If
            Else ' Value not found.
                'dCell.Value = ""
            End If
        End If
    End If

End Sub