Excel VBA按钮复制tblkasir到tbldafta时无响应且循环至最后行求助

我尝试通过按钮将tblkasir表的数据复制到tbldafta表，但点击按钮后Excel无响应，且持续添加数据直至最后一行。以下是按钮的脚本代码：

Private Sub cmdSimpan_Click()
    SimpanNota
    SimpanDafta
End Sub


Sub SimpanNota()
    ActiveWorkbook.Sheets("kasir").Activate
    Sheets("kasir").Range("Q4").Select

    Do
        If IsEmpty(ActiveCell) = False Then
            ActiveCell.Offset(1, 0).Select
        End If
    Loop Until IsEmpty(ActiveCell) = True

    ActiveCell.Value = Sheets("kasir").Range("N3").Value
End Sub


Sub SimpanDafta() 'this is the script that keep looping
    ActiveWorkbook.Sheets("daftar transaksi").Activate
    Sheets("daftar transaksi").Range("tbldafta[[nomor transaksi]:[jumlah]]").Select

    Do
        If IsEmpty(ActiveCell) = False Then
            ActiveCell.Offset(1, 0).Select
        End If
    Loop Until IsEmpty(ActiveCell) = True

    Sheets("daftar transaksi").Select
    Sheets("kasir").Range("tblkasir[[nomor transaksi]:[jumlah]]").Copy Destination:=Sheets("daftar transaksi").Range(Selection, Selection.End(xlDown))
    ActiveCell.Offset(1, 1).Range("C9") = Sheets("daftar transaksi").Range(Selection, Selection.End(xlDown))
    Application.CutCopyMode = False
    Sheets("kasir").Range("tblkasir[[nomor transaksi]:[jumlah]]").ClearContents
    Sheets("kasir").Range("K4").ClearContents
End Sub

附sheets daftar transaksi与sheets kasir的截图：

问题分析与修复方案 #

核心问题点 #

1. 低效且易异常的空行查找：原代码用Do...Loop逐行选择单元格找空行，若表格存在隐藏行或数据量较大，容易陷入无意义循环；
2. 复制目标范围错误：Range(Selection, Selection.End(xlDown))会将目标范围直接拉到列的最后一行，导致复制的数据被填充到数万行空单元格，引发Excel无响应；
3. 冗余错误的赋值语句：ActiveCell.Offset(1, 1).Range("C9") = ...逻辑混乱，无实际作用且干扰执行流程；
4. 过度依赖Activate/Select：这类操作不仅效率低，还容易因选中状态变化导致逻辑出错。

修复后的代码 #

Private Sub cmdSimpan_Click()
    SimpanNota
    SimpanDafta
End Sub

Sub SimpanNota()
    Dim wsKasir As Worksheet
    Set wsKasir = ThisWorkbook.Sheets("kasir")
    
    ' 快速定位Q列从Q4开始的第一个空行
    Dim lastRowQ As Long
    lastRowQ = wsKasir.Cells(wsKasir.Rows.Count, "Q").End(xlUp).Row + 1
    If lastRowQ < 4 Then lastRowQ = 4 ' 确保起始行不小于Q4
    
    wsKasir.Cells(lastRowQ, "Q").Value = wsKasir.Range("N3").Value
End Sub

Sub SimpanDafta()
    Dim wsKasir As Worksheet, wsDaftar As Worksheet
    Dim tblKasir As ListObject, tblDafta As ListObject
    Dim sourceData As Range
    
    ' 绑定工作表和结构化表格对象
    Set wsKasir = ThisWorkbook.Sheets("kasir")
    Set wsDaftar = ThisWorkbook.Sheets("daftar transaksi")
    Set tblKasir = wsKasir.ListObjects("tblkasir")
    Set tblDafta = wsDaftar.ListObjects("tbldafta")
    
    ' 源表无数据则直接退出
    If tblKasir.ListRows.Count = 0 Then Exit Sub
    
    ' 获取需要复制的源数据范围（排除表头）
    Set sourceData = tblKasir.ListColumns("nomor transaksi").DataBodyRange _
        .Resize(, tblKasir.ListColumns("jumlah").Index - tblKasir.ListColumns("nomor transaksi").Index + 1)
    
    ' 在目标表添加新行并复制数据
    Dim newRow As ListRow
    Set newRow = tblDafta.ListRows.Add(AlwaysInsert:=True)
    sourceData.Copy Destination:=newRow.Range.Resize(, sourceData.Columns.Count)
    
    ' 清除源表数据
    tblKasir.DataBodyRange.ClearContents
    wsKasir.Range("K4").ClearContents
    Application.CutCopyMode = False
End Sub

修复说明 #

• 直接引用工作表和ListObject结构化表格对象，完全避免Activate/Select操作，提升执行效率和稳定性；
• 用End(xlUp)快速定位最后一行，替代低效的逐行循环；
• 利用结构化表格的ListRows.Add方法添加新行，自动适配表结构，避免错误扩展范围；
• 精准控制复制的数据范围，仅将源表数据复制到目标表的新行，彻底解决无限填充问题。

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