VBA数据迁移代码问题：工作表未显示值排查

原代码核心问题 #

1. 逻辑偏离需求：VerificarLinhasVazias函数的作用是查找连续3个空列，但需求是当目标行对应列非空时，跳过2列再粘贴，两者逻辑完全不匹配，导致无法正确定位粘贴位置。
2. 硬编码列位置：固定使用AC、AD等列，无法适应动态的空列情况，扩展性差。
3. 匹配效率低下：嵌套循环遍历目标表所有行找ID，数据量大时运行缓慢。
4. 复制操作冗余：逐个单元格Copy会携带格式，且效率低于直接赋值。

修正后的代码 #

Sub TransferirDados()
    Dim arquivoOrigem As String
    Dim wbOrigem As Workbook
    Dim planilhaOrigem As Worksheet
    Dim planilhaDestino As Worksheet
    Dim ultimaLinhaOrigem As Long
    Dim ultimaLinhaDestino As Long
    Dim i As Long
    Dim dictID As Object
    Dim linhaDestino As Long
    Dim colunaG As Long ' 用于定位G列数据的粘贴位置
    
    ' 设置源文件路径（请替换为实际路径）
    arquivoOrigem = "C:\你的文件路径\源文件.xlsx"
    
    ' 打开源文件并处理异常
    On Error Resume Next
    Set wbOrigem = Workbooks.Open(Filename:=arquivoOrigem)
    On Error GoTo 0
    If wbOrigem Is Nothing Then
        MsgBox "无法打开源文件，请检查路径是否正确！", vbCritical
        Exit Sub
    End If
    
    ' 指定源表和目标表
    Set planilhaOrigem = wbOrigem.Sheets("Sheet1")
    Set planilhaDestino = ThisWorkbook.Sheets("Controle Geral 2023")
    
    ' 获取源表和目标表的最后行
    ultimaLinhaOrigem = planilhaOrigem.Cells(planilhaOrigem.Rows.Count, "C").End(xlUp).Row
    ultimaLinhaDestino = planilhaDestino.Cells(planilhaDestino.Rows.Count, "A").End(xlUp).Row
    
    ' 创建字典存储ID与目标行的映射，提升匹配效率
    Set dictID = CreateObject("Scripting.Dictionary")
    For i = 2 To ultimaLinhaDestino
        Dim idValor As String
        idValor = CStr(planilhaDestino.Cells(i, "A").Value)
        If Not dictID.Exists(idValor) Then
            dictID.Add idValor, i
        End If
    Next i
    
    ' 遍历源表数据
    For i = 2 To ultimaLinhaOrigem
        If planilhaOrigem.Cells(i, "C").Value <> "" Then
            idValor = CStr(planilhaOrigem.Cells(i, "C").Value)
            ' 检查字典中是否存在匹配的ID
            If dictID.Exists(idValor) Then
                linhaDestino = dictID(idValor)
                
                ' 定位G列数据的粘贴位置：从AD列开始，找第一个空单元格，非空则跳2列
                colunaG = planilhaDestino.Cells(linhaDestino, "AD").Column
                Do While planilhaDestino.Cells(linhaDestino, colunaG).Value <> ""
                    colunaG = colunaG + 2 ' 非空则跳过2列
                Loop
                
                ' 直接赋值（避免复制格式，提升效率）
                planilhaDestino.Cells(linhaDestino, "AC").Value = planilhaOrigem.Cells(i, "F").Value
                planilhaDestino.Cells(linhaDestino, colunaG).Value = planilhaOrigem.Cells(i, "G").Value
                planilhaDestino.Cells(linhaDestino, "B").Value = planilhaOrigem.Cells(i, "C").Value
            End If
        End If
    Next i
    
    ' 关闭源文件
    wbOrigem.Close SaveChanges:=False
    
    MsgBox "Dados transferidos com sucesso!", vbInformation
End Sub

关键修复点说明 #

1. 替换匹配逻辑：用Scripting.Dictionary存储目标表的ID与行号映射，O(1)时间查找匹配行，彻底解决嵌套循环效率问题。
2. 动态定位粘贴列：从AD列开始循环检查，找到第一个空单元格；若当前列非空，直接跳过2列，完全符合需求。
3. 优化赋值方式：直接用.Value赋值，避免复制格式，同时提升运行速度。
4. 增加错误处理：添加源文件打开失败的判断，避免程序崩溃。

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