Importar do Excel através de Recordset informando a Coluna e não Nome dos Campos excel

Quando a planilha do Excel não possui padrão em nomes de campos e nao sendo possível renomear suas colunas não é possível utilizar o método .TransferSpreadsheet pois este método tanto a Tabela Access quanto a do Excel precisam ter o mesmo Nome de campos.
Veja um exemplo de planilha que necessito importar os dados:


É possível perceber que a linha com cabeçalho dos campos, não tem padrão... Alguns tem até tres linha como nome de Campos... Alem de conter colunas mescladas...
Dessa forma é impossível utilizar os Nomes das colunas...

O método utilizado aqui:
Realiza a abertura da Planilha Excel;
Abre um Recordset na Planilha;
Transfere os dados do Excel para a tabela do Access tendo como base o Numero de Colunas e não nome de campos.

parte do Código foi adaptado do site UsandoAccess.com

Código:

Private Sub btImportar_Click()
'------------------------------------------------------------------'
'              Adaptado do site UsandoAccess.com                   '
'                 Por FabioPaes em 24/01/2017                      '
'------------------------------------------------------------------'
Dim strTabela As String
Dim strSQL As String
Dim bdExcel As DAO.Database
Dim rs, rs1 As DAO.Recordset
'Passa o local e nome do arquivo para a variável
strArquivo = CurrentProject.Path & "\Exemplo.xlsx"
'Abre arquivo ListaClientes.xls
Set bdExcel = OpenDatabase(strArquivo, False, False, "Excel 12.0;HDR=Yes;IMEX=0;")
'Monta a consulta do Recordset
strSQL = "SELECT * FROM [Planilha1$]"
'Abre o Recordset da consulta
Set rs = bdExcel.OpenRecordset(strSQL)
'Abre o recordset na tabela que recebera os dados
Set rs1 = CurrentDb.OpenRecordset("tb1")
'Adiciona os dados a tabela tb1
Do While Not rs.EOF
rs1.AddNew
    'verifico antes sem tem dados na primeira coluna, se tiver eu lanço, se nao eu ignoro!
    If Nz(Len(rs(0)), 0) > 0 Then
    
    rs1!Pos = rs(0) '0 é a primeira coluna do Excel
    rs1!NProduto = rs(1)
    rs1!Descricao = rs(2)
    rs1!Qnt = rs(4)
    rs1!valUnit = rs(13)
    rs1!ValorTotal = rs(14)
rs1.Update
    End If
rs.MoveNext
Loop

'fecha o Recordset
rs.Close
Set rs = Nothing
rs1.Close
Set rs1 = Nothing
'Fecha o arquivo Excel
bdExcel.Close
Set bdExcel = Nothing
MsgBox "A Tabela foi Atualizada...", vbInformation, "Aviso"

End Sub


Obs: Considere a primeira coluna do Excel como sendo a coluna 0 e assim por diante (0,1,2,3,4,5...)

Olá Fábio, Parabéns!
Obrigado pela partilha e dedicação.
Mais uma para a comunidade MaximoAccess.
Abraço

Fabio, mais uma vez muito obrigado pela ajuda.

Gostaria de parabeniza-lo pelo excelente trabalho e dedicação em ajudar o próximo.


Abraços!

Grato aos Amigo!!! Ate a Proxima se Deus quiser!!!

Muito Obrigado!
Rápido e simples!