Excel VBA跨表数据同步代码问题咨询：行增删异常

需求说明 #

• 将Sheet1第7行开始的B:I列、M:O列数据及格式同步至Sheet2的B:K列（从第7行开始）
• 同步截止行：Sheet1中B列包含"SGRE"的上一行
• 支持自动捕获Sheet1的变更触发同步，后续可添加手动触发按钮

现存问题 #

1. Sheet1新增行后，Sheet2仅B:K列新增对应行，M:W列（手动维护数据）未同步新增整行，需实现B:W整行同步
2. Sheet1新增行后删除该行，再次运行代码时Sheet2未同步删除，反而出现重复行（如原最后行B1199为"AAA"，操作后B1199与B1200均为"AAA"）

原代码 #

Sub CopyPartialDataToSheet2()
    'Declare variables
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range

    'Set worksheets
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")


    'Find last row in Sheet1 and Sheet2
    lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row

    'Find last row to be copied in Sheet1
    Do While ws1.Cells(lastRow1, "B").Value <> "SGRE"
        lastRow1 = lastRow1 - 1
    Loop
    lastRow1 = lastRow1 - 1

    'Print debug information
    Debug.Print "lastRow1: " & lastRow1 & ", lastRow2: " & lastRow2
    
    'Set ranges to be copied
    Set rng1 = ws1.Range("B7:I" & lastRow1)
    Set rng2 = ws1.Range("M7:O" & lastRow1)

    'Copy ranges from Sheet1 to Sheet2
    rng1.Copy ws2.Range("B7")
    rng2.Copy ws2.Range("B7").Offset(0, rng1.Columns.Count)

    'Adjust column widths in Sheet2 to match those in Sheet1
    For i = 1 To rng1.Columns.Count
        ws2.Columns(i).ColumnWidth = ws1.Columns(i).ColumnWidth
    Next i
    For i = 1 To rng2.Columns.Count
        ws2.Columns(i + rng1.Columns.Count).ColumnWidth = ws1.Columns(i + rng1.Columns.Count).ColumnWidth
    Next i
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    'Declare variables
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rngHeights As Range
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long

    'Exit the sub if the change was not made in Sheet1
    If Target.Parent.Name <> "Sheet1" Then Exit Sub

    'Set worksheets
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")

    'Find last row in Sheet1 and Sheet2 
    lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row

    'Find last row to be copied in Sheet1
    Do While ws1.Cells(lastRow1, "B").Value <> "SGRE"
        lastRow1 = lastRow1 - 1
    Loop
    lastRow1 = lastRow1 - 1

    'Print debug information
    Debug.Print "lastRow1: " & lastRow1 & ", lastRow2: " & lastRow2

    'Set ranges to be copied
    Set rng1 = ws1.Range("B7:K" & lastRow1)
    Set rng2 = ws1.Range("M7:O" & lastRow1)
    Set rng3 = ws1.Range("M7:W" & lastRow1)

    'Copy data and row heights from Sheet1 to Sheet2
    rng1.Copy ws2.Range("B7")
    rng2.Copy ws2.Range("B7").Offset(0, rng1.Columns.Count)
    If lastRow1 > lastRow2 Then
        ws2.Range("B" & lastRow2 + 1 & ":K" & lastRow1).Insert Shift:=xlDown
        rng3.Copy ws2.Range("B" & lastRow2 + 1).Offset(0, rng1.Columns.Count + rng2.Columns.Count)
        Set rngHeights = ws1.Range("B" & lastRow2 + 1 & ":B" & lastRow1)
        For i = 1 To rngHeights.Rows.Count
            ws2.Rows(lastRow2 + i).RowHeight = rngHeights.Rows(i).RowHeight
        Next i
    End If
End Sub

修复后代码 #

Option Explicit

Sub SyncSheet1ToSheet2()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim targetLastRow As Long, sgreRow As Long
    Dim syncRowsCount As Long, currentSheet2Rows As Long
    
    ' 定义工作表对象
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' 定位Sheet1中B列"SGRE"所在行，确定同步截止行
    sgreRow = ws1.Columns("B").Find(What:="SGRE", LookIn:=xlValues, LookAt:=xlWhole).Row
    targetLastRow = sgreRow - 1
    syncRowsCount = targetLastRow - 6 ' 计算需要同步的行数（第7行到targetLastRow的总行数）
    
    ' 清除Sheet2原有同步数据行（保留前6行表头）
    currentSheet2Rows = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
    If currentSheet2Rows >= 7 Then
        ws2.Rows("7:" & currentSheet2Rows).Delete
    End If
    
    ' 插入对应数量的整行，确保B:W区域同步行数
    If syncRowsCount > 0 Then
        ws2.Rows("7:" & 6 + syncRowsCount).Insert Shift:=xlDown
    End If
    
    ' 复制Sheet1 B:I列数据及格式到Sheet2对应位置
    ws1.Range("B7:I" & targetLastRow).Copy
    ws2.Range("B7").PasteSpecial xlPasteAll
    
    ' 复制Sheet1 M:O列数据及格式到Sheet2对应位置（B列偏移8列即J列）
    ws1.Range("M7:O" & targetLastRow).Copy
    ws2.Range("B7").Offset(0, 8).PasteSpecial xlPasteAll
    
    ' 同步行高
    Dim i As Long
    For i = 7 To targetLastRow
        ws2.Rows(i).RowHeight = ws1.Rows(i).RowHeight
    Next i
    
    ' 同步列宽
    ' 同步B-I列
    For i = 2 To 9
        ws2.Columns(i).ColumnWidth = ws1.Columns(i).ColumnWidth
    Next i
    ' 同步J-L列（对应Sheet1 M-O列）
    For i = 10 To 12
        ws2.Columns(i).ColumnWidth = ws1.Columns(i + 3).ColumnWidth
    Next i
    
    Application.CutCopyMode = False
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    
    ' 仅当Sheet1的同步区域（B:I、M:O）发生变更时触发同步
    If Target.Parent.Name = ws1.Name Then
        If Not Intersect(Target, ws1.Range("B:I,M:O")) Is Nothing Then
            Application.EnableEvents = False ' 禁用事件防止循环触发
            SyncSheet1ToSheet2
            Application.EnableEvents = True
        End If
    End If
End Sub

修复说明 #

1. 整行同步问题解决

   • 不再针对局部列插入行，而是直接对Sheet2第7行及以后的整行进行删除/插入操作，确保M:W区域的手动维护数据行也同步变化。
   • 先清除旧数据行再插入新行，保证行数完全匹配Sheet1的同步区域。

2. 重复行/未删除问题解决

   • 每次同步前强制删除Sheet2中第7行及以后的所有旧数据，彻底避免残留数据导致重复。
   • 直接通过Find方法定位"SGRE"行，计算准确的同步行数，确保Sheet2始终与Sheet1同步区域行数一致。

3. 其他优化

   • 加入Option Explicit强制变量声明，减少潜在错误。
   • 限定Worksheet_Change的触发范围，仅当同步区域变更时才执行同步，提升性能。
   • 禁用事件触发防止循环调用，避免不必要的重复执行。

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