Public Function importExcelData(tbl As String, ByVal wrkBook As String, ByVal rng As String, Optional ByVal shtNumber As Integer = 1)
' arnelgp
'
' Note:
'
' the excel sheet must have Column Header for this to work.
' rng must not include the Column Header (only the data to import)
'
' answer to:
' https://www.access-programmers.co.uk/forums/threads/copying-data-from-excel-and-pasting-in-an-access-table.316926/
' DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "TestTable", "M:\DATBASES ALL PROGRAM\Test.xlsx", True, "A2:C24"
'
'
Dim cFields As New Collection
Dim objExcel As Object
Dim objWbk As Object
Dim objSht As Object
Dim start_column As Long, end_column As Long
Dim start_row As Long, end_row As Long
Dim v As Variant, i As Long, j As Long
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sColumn As String, bOK As Boolean
Set db = CurrentDb
Set rs = db.OpenRecordset(tbl, dbOpenDynaset)
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open(wrkBook)
Set objSht = objWbk.Sheets(shtNumber)
'get the header
v = Split(rng, ":")
With objSht
start_column = .Range(LetterOnly(v(0)) & "1").Column
start_row = NumberOnly(v(0))
end_column = .Range(LetterOnly(v(1)) & "1").Column
end_row = NumberOnly(v(1))
For i = start_column To end_column Step 1
sColumn = .Cells(1, i).Value & ""
bOK = False
If Len(sColumn) > 0 Then
For j = 0 To rs.Fields.Count - 1
If rs.Fields(j).Name = sColumn Then
bOK = True
Exit For
End If
Next
If bOK Then
cFields.Add sColumn, i & ""
Else
cFields.Add "", i
End If
End If
Next i
'save the data to the table
For i = start_row To end_row Step 1
rs.AddNew
For j = start_column To end_column Step 1
If Len(cFields(j)) > 0 Then
v = .Cells(i, j).Value
rs(cFields(j & "")).Value = v
End If
Next
rs.Update
Next
End With
'housekeeping
Set objSht = Nothing
objWbk.Close
Set objWbk = Nothing
objExcel.Quit
Set objExcel = Nothing
rs.Close
Set rs = Nothing
Set db = Nothing
End Function
Public Function LetterOnly(ByVal ps As String) As String
LetterOnly = getps(ps, "string")
End Function
Public Function NumberOnly(ByVal ps As String) As Long
NumberOnly = getps(ps, "number")
End Function
Public Function getps(ByVal ps As String, pn As String) As Variant
With CreateObject("VBScript.RegExp")
If pn = "string" Then
.Pattern = "[^a-z]"
Else
.Pattern = "[^0-9]"
End If
.Global = True
.IgnoreCase = True
getps = Trim(.Replace(ps, ""))
End With
End Function
