Bom dia.

Alguém poderia me ajudar a identificar o erro?

Não entendi sua planilha, mas tente fazer algo parecido com isto:

'Option Explicit

Sub AtivDiarias_ItemCadastrado_Inserir()
    
    Dim TabelaOrigem As ListObject, TabelaDestino As ListObject
    Dim varDados() As Variant
    
    Set TabelaOrigem = Wsh_Config.ListObjects("TB_AtivCadastradas")
    Set TabelaDestino = Wsh_AtivDiarias.ListObjects("TB_AtivDiarias")
    
    Mes_Atual = Wsh_AtivDiarias.Range("AtivDiarias_Mes").Value2
    Ano_Atual = Wsh_AtivDiarias.Range("AtivDiarias_Ano").Value
    
    TotalLinhas = TabelaOrigem.DataBodyRange.Rows.Count
    TotalColunas = TabelaOrigem.DataBodyRange.Columns.Count
    
    Col_Zero = TabelaOrigem.DataBodyRange.Range("A1").Column - 1
    Col_Period = TabelaOrigem.ListColumns("Periodicidade").DataBodyRange.Column - Col_Zero
    Col_Data = TabelaOrigem.ListColumns("Data").DataBodyRange.Column - Col_Zero
    Col_ID = TabelaOrigem.ListColumns("ID").DataBodyRange.Column - Col_Zero
    Col_Classif = TabelaOrigem.ListColumns("Classificação").DataBodyRange.Column - Col_Zero
    
    ID_Cadastrado = Wsh_AtivDiarias.Range("AtivDiarias_Consulta_ID").Value
    
    ImportaItens = MsgBox("Deseja Inserir novo item ?", vbYesNo)
    
    If ImportaItens = vbNo Then
        Exit Sub
    Else
        Wsh_Config.Range("Config_Mes").Value2 = Wsh_AtivDiarias.Range("AtivDiarias_Mes").Value2
        Wsh_Config.Range("Config_Ano").Value = Wsh_AtivDiarias.Range("AtivDiarias_Ano").Value
        
        ReDim varDados(1 To TotalLinhas, 1 To TotalColunas) As Variant
        
        varDados = TabelaOrigem.DataBodyRange

        For NumLinha = 1 To TotalLinhas
            If varDados(NumLinha, Col_ID) = ID_Cadastrado Then
                Linha_ID = NumLinha
                Exit For
            End If
        Next NumLinha



        With TabelaDestino.ListRows.Add(1) 'Adiciona uma linha
            .Range(1, 2) = varDados(Linha_ID, Col_Data)
            .Range(1, 4) = varDados(Linha_ID, Col_ID)                       'Coluna ID
            .Range(1, 6).Resize(, 2) = varDados(Linha_ID, Col_Classif)          'Coluna Periodicidade / Classificação
        End With
        
        TabelaDestino.ListColumns("Data").DataBodyRange.Cells(1, 1).Select
        
    End If
    
    Set TabelaOrigem = Nothing
    Set TabelaDestino = Nothing
    Erase varDados
    Erase datData
    Erase varGrupo_A
    Erase varGrupo_B
    
End Sub

Quase deu certo... porém ele incluiu o valor da Coluna [Classificação] da Tabela de Origem tanto na Coluna [Periodicidade] quanto na Coluna [Classificação] da Tabela de Destino.

Era para ter inserido os dados da Coluna [Periodicidade] da Tabela de Origem na Coluna [Periodicidade] da Tabela de Destino e os dados da Coluna [Classificação] da Tabela de Origem na Coluna [Classificação] da Tabela de Destino.

Algo nesse linha não funcionou:

.Range(1, 6).Resize(, 2) = varDados(Linha_ID, Col_Classif)          'Coluna Periodicidade / Classificação

Ou a Matriz não está correta ou o "Resize" não funcionou. Me parece que não armazenou os dados das duas colunas em uma Matriz.

Tente retirar o resize e faça todas as colunas da forma abaixo, apenas mudando o número e o nome da coluna:

.Range(1, 4) = varDados(Linha_ID, Col_ID)

A ideia era diminuir as linhas de código.... mas assim resolveu.

Obrigado!