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

Question

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

让我解释一下。例如，Sheet1在Range("L1:L" & lastrow)中有多个值，如果范围("E4")为空，则L1值将在E4

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

如果L4有最后一个值，则退出子，因为下面的代码正在工作。

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

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

写下一个单元格值

• 注意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

Answer 2

请尝试下一个代码:

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