将单元格值从一张纸复制到另一张纸，并将其粘贴到具有特定值的单元格附近

debugcn 发表于 Dev

亚奇尼奥

我的工作任务很固定，需要将数字列表复制到另一张纸上。在该工作表中，我需要将这些数字一个接一个地粘贴到具有特定值（在列中重复）的单元格右侧的单元格中。（请注意，目标表按该值-“מודלתגובה”排序，并且存在隐藏的行。

很难解释，所以我希望这些图像能做到。

我试图编写合适的代码，但是不断出现不同的错误。将单元格值复制到目标单元格时似乎会出现问题。

Dim i As Integer
i = 4

Do While IsEmpty(Cells(i, 1).Value) = False
    Worksheets(1).Select
    Cells(i, 1).Copy
    Worksheets(2).Select
    Cells.Find(What:="מודל תגובה", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(0, -1).Activate

    If IsEmpty(ActiveCell.Value) = False Then
         Selection.FindNext(After:=ActiveCell).Activate
         ActiveCell.Offset(0, -1).Paste
    Else
         ActiveCell.Offset(0, -1).Select
         ActiveCell.Paste  
    End If

    i = i + 1
Loop

很抱歉提供了拙劣的代码（实际上是我的第一个宏）。

ᴇʜ

解决方案是仅遍历过滤范围的可见单元格。

"מודל תגובה"在运行此代码之前，请确保已过滤目标位置。在运行此代码之前，它需要看起来像您的第二张图像。

Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets(1)

Dim DestinationSheet As Worksheet
Set DestinationSheet = Worksheets(2)

Dim LastRow As Long
LastRow = DestinationSheet.Cells(DestinationSheet.Rows.Count, "B").End(xlUp).Row

Dim VisibleCells As Range
On Error Resume Next 'next line errors if no visible cells so we turn error reporting off
Set VisibleCells = DestinationSheet.Range("A2", "A" & LastRow).SpecialCells(xlCellTypeVisible)
On Error Goto 0 'turn error reporting on or you won't see if other errors occur

If VisibleCells Is Nothing Then  'abort if no cells are visible in the filter
    MsgBox "No cells to paste at"
    Exit Sub
End If

Dim SourceRow As Long
SourceRow = 4   'start row in your source sheet

Dim Cell As Range
For Each Cell In VisibleCells.Cells    'loop through visible cells
    Cell.Value = SourceSheet.Cells(SourceRow, "A").Value 'copy value
    SourceRow = SourceRow + 1  'incerease source row
Next Cell

确保定义DestinationSheet并SourceSheet使用您的工作表名称。

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。