Tranferring data from an excel array to ms access table

[carlleese24]

Hi

I am trying to transfer data that's in this format table format to ms access.

[table="width: 500, class: grid, align: left"]
[tr]
[td]description[/td]
[td]Values[/td]
[td]Dates_[/td]
[td]Year_[/td]
[td]Wk_no[/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[tr]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[/tr]
[/table]


Heres the code below I am using which puts the data into an array like the table above but I keep getting Type mismatch error message when it tries to transfer the data to Ms access. The code highlighted in red is used to transfer the data to ms access. If someone could please help me resolve this issue many thanks in advance..

Sub sbAExampleOnTwoDimnsionalArray11()

    Dim ArrayFinalData()
    Dim lrows As Long
    Dim lcols As Long
    
With Sheets("FinalData")

   Description_Col = 1
   Titles = 3 + 1 'e.g years, wk no, dates
   
LR = Sheets("FinalData").Range("a" & Sheets("FinalData").Rows.Count).End(xlUp).Row - Titles + 1
LR2 = LR + 1
   
   lcols = .Cells(5, .Columns.Count).End(xlToLeft).Column - Description_Col
    lcolsa = .Cells(5, .Columns.Count).End(xlToLeft).Column * LR + 1
    lrows = Titles + Description_Col
End With

 
    ReDim Preserve ArrayFinalData(0 To lcolsa, 0 To lrows)
     

For h = 1 To lcols

If k = 0 Then
k = k + LR2
m = m + 1
End If

If m = LR2 Then
m = m + 1
End If

If i = LR2 Then
i = i + 1
End If


For i = m To k

If L = 0 Then
L = L + Titles
Else
L = L + 1
End If

   
If i = 1 Then
 i = i - 1

     ArrayFinalData(i, 0) = "description"
    ArrayFinalData(i, 1) = "Values"
    ArrayFinalData(i, 2) = "Dates_"
    ArrayFinalData(i, 3) = "Year_"
    ArrayFinalData(i, 4) = "Wk_no"
     i = i + 2
        
End If
    
    For j = 1 To 2
    
     h = h + 1
    i = i - 1
    ArrayFinalData(i, 0) = Sheets("FinalData").Cells(L, 1)
    ArrayFinalData(i, 1) = Sheets("FinalData").Cells(L, h)
    ArrayFinalData(i, 2) = Sheets("FinalData").Cells(3, h)
    ArrayFinalData(i, 3) = Sheets("FinalData").Cells(1, h)
    ArrayFinalData(i, 4) = Sheets("FinalData").Cells(2, h)
    
 i = i + 1
   h = h - 1
   
      
   
    Next j
 

   Next i

L = L - LR


If i < lcolsa Then
k = k + LR
m = m + LR
End If

Next h


Dim Destination As Range
Set Destination = Range("z16")
Destination.Resize(UBound(ArrayFinalData, 1), UBound(ArrayFinalData, 2)).Value = ArrayFinalData


[COLOR="#FF0000"]   

    Dim cnn As ADODB.Connection
    Dim MyConn
    Dim rst As ADODB.Recordset
  
 
    TARGET_DB = "C:\info.accdb"

    Set cnn = New ADODB.Connection
    MyConn = TARGET_DB
    
    With cnn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Open MyConn
    End With


    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseServer
    rst.Open Source:="Table1", ActiveConnection:=cnn, _
             CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
             Options:=adCmdTable

 
For j = 0 To UBound(ArrayFinalData, 1) 'loop through records
 rst.AddNew
 For f = 0 To UBound(ArrayFinalData, 2) 'loop through fields
 rsR.Fields(f).Value = ArrayFinalData(j, f)

 
 Next f
 rst.Update
 Next j

 rst.Close



    
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing

[/COLOR]

End Sub

kind regards
Carl