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

Question

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

很难解释，所以我希望图片可以。

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

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

抱歉我的代码很糟糕（实际上是我的第一个宏）。

Answer 1

解决方案是仅循环过滤范围内的可见单元格。

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

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。

Answer 2

试试这个：

Dim i As Integer
Dim Last_Row as Long
Worksheets(1).Select
'The "1" Of the line below means that the variable gonna count the rows of the first column (A)
Last_Row = Application.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:A" & Last_Row).Copy
Worksheets(2).Select
Range("A1").Select
ActiveSheet.Paste