VBA循环问题：逐部门复制账户列表粘贴到最后一行功能异常如何修复

• 工作表名称不匹配：代码中使用的目标工作表名称为Account and Dpt，与实际存在的Departments and Accounts名称不符，无法正确定位目标表导致操作失效
• 行号变量未更新：lrow仅在循环开始前计算了一次，每次循环粘贴后没有重新计算目标表的最后一行，所有内容都会粘贴到同一位置，出现内容覆盖导致看似无运行效果
• 循环计数逻辑错误：For循环本身会自动对计数器i执行递增操作，代码中额外添加的i = i + 1会导致每次循环i实际增加2，跳过半数部门
• 硬编码适配性差：代码中写死了循环次数47、账户复制范围A2:A178，若后续部门、账户数量变动，代码无法自动适配
• 大量使用Select语法：录制宏生成的Select/Selection语法依赖当前激活工作表状态，容易因激活表异常导致操作错位，且运行效率极低

Sub 生成部门账户对应表()
    Dim 账户数量 As Long, 部门数量 As Long, 目标表最后行 As Long
    Dim i As Long
    ' 定义工作表对象，避免反复切换表
    Dim wsDept As Worksheet, wsAcc As Worksheet, wsTarget As Worksheet
    Set wsDept = ThisWorkbook.Sheets("Department")
    Set wsAcc = ThisWorkbook.Sheets("Accounts")
    Set wsTarget = ThisWorkbook.Sheets("Departments and Accounts")
    
    ' 清空目标表原有内容，可根据需求注释掉该行
    wsTarget.Cells.Clear
    
    ' 自动计算账户数量、部门数量，不用硬编码
    账户数量 = wsAcc.Cells(wsAcc.Rows.Count, "A").End(xlUp).Row - 1 ' 减1是跳过表头
    部门数量 = wsDept.Cells(wsDept.Rows.Count, "B").End(xlUp).Row - 1 ' 减1是跳过表头
    
    For i = 1 To 部门数量
        ' 计算当前要粘贴的起始行
        目标表最后行 = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
        ' 复制账户到目标表A列
        wsAcc.Range("A2:A" & 账户数量 + 1).Copy wsTarget.Range("A" & 目标表最后行)
        ' 批量填充对应部门到B列，无需重复粘贴
        wsTarget.Range("B" & 目标表最后行).Resize(账户数量, 1).Value = wsDept.Range("B" & i + 1).Value
    Next i
    
    ' 清空剪贴板
    Application.CutCopyMode = False
    MsgBox "生成完成！"
End Sub

修复后的代码取消了所有Select操作，运行效率更高，且自动适配变动的部门、账户数量，不需要手动修改硬编码参数，中文命名也方便后续调整维护。

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