如何仅复制Project工作表中Sheet1空白行对应内容及A列新条目？

我明白你的核心诉求——原来的代码会把Project表的所有行一股脑复制过来，但你需要精准处理两个需求：一是给Sheet1的空单元格补全对应工作表的内容，二是只把Project表中Sheet1空白行对应的新条目复制过去。下面是适配你需求的修改版代码：

Sub CopyNewEntriesAndFillBlanks()
    Dim wsSheet1 As Worksheet
    Dim wsProject As Worksheet
    Dim lastRowSheet1 As Long
    Dim lastRowProject As Long
    Dim i As Long
    Dim cell As Range
    
    ' 绑定目标工作表，可根据实际名称调整
    Set wsSheet1 = ThisWorkbook.Worksheets("Sheet1")
    Set wsProject = ThisWorkbook.Worksheets("Project")
    
    ' 获取两个工作表A列的最后非空行位置
    lastRowSheet1 = wsSheet1.Cells(wsSheet1.Rows.Count, "A").End(xlUp).Row
    lastRowProject = wsProject.Cells(wsProject.Rows.Count, "A").End(xlUp).Row
    
    ' 需求1：填充Sheet1中的空单元格（从Project对应位置复制内容）
    For i = 1 To lastRowSheet1
        For Each cell In wsSheet1.Rows(i).Cells
            ' 只处理当前工作表的空单元格，从Project同位置复制
            If Trim(cell.Value) = "" Then
                cell.Value = wsProject.Cells(cell.Row, cell.Column).Value
            End If
        Next cell
    Next i
    
    ' 需求2：仅复制Project中Sheet1空白行对应的新条目
    For i = lastRowSheet1 + 1 To lastRowProject
        ' 确保Project的A列有内容才复制，避免空行干扰
        If Trim(wsProject.Cells(i, "A").Value) <> "" Then
            wsProject.Rows(i).Copy Destination:=wsSheet1.Cells(wsSheet1.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next i
    
    ' 清除剪贴板状态，避免后续弹窗提示
    Application.CutCopyMode = False
End Sub

代码关键点说明： #

• 精准定位行范围：用End(xlUp)获取A列最后非空行，避免处理无效的空白区域
• 空单元格填充逻辑：遍历Sheet1已有行的每个单元格，仅为空的单元格从Project对应位置补全内容
• 新条目复制逻辑：只处理Sheet1最后非空行之后的Project行，且仅复制Project中A列有实际内容的行，完全匹配你要的"仅复制新条目"需求
• 优化体验：最后清除剪贴板状态，避免Excel弹出粘贴提示

如果需求1中的"另一工作表"不是Project，只需要把代码里的wsProject替换成目标工作表的名称即可。

内容的提问来源于stack exchange，提问作者Ahmet