Admin
10-14-2011, 08:25 AM
Hi All.
If you want to export a range of data into an Access table (Either before or 2007 or Post 2007), here is a sub. This also allows you to either create a new table or append an existing table.
Option Explicit
Public Enum TableProperty
AppendTable = 0
CreateTable = 1
End Enum
Private Const strTitle As String = "ExcelFox.com"
Sub ExportRangeIntoAccess(ByVal DB_FilePath As String, ByVal DB_Name As String, _
ByVal Tbl_Name As String, _
ByVal xl_SheetName As String, _
ByVal HeaderYes As Boolean, _
ByVal TableProp As TableProperty, _
Optional ByVal RangeAddress As String, _
Optional ByVal DefinedRngName As String, _
Optional ByVal ClearTable As Boolean = True)
Dim adoConn As Object
Dim wbkActive As Workbook
Dim wbkTemp As Workbook
Dim wksSource As Worksheet
Dim wksTemp As Worksheet
Dim rngFirstCell As Range
Dim strAddress As String
Dim strDataRange As String
Dim arrNameRanges() As String
Dim strTempFPath As String
Dim strTempFullName As String
Dim strDBFullName As String
Dim strExtn As String
Dim Hdr As Variant
Dim lngLoop As Long
Dim lngStartRow As Long
Dim lngEndRow As Long
Dim lngRowsSoFar As Long
Dim lngLastCol As Long
Dim lngLastRow As Long
Dim lngSU As Long
Dim Flg As Boolean
Dim rngBlank As Range
With Application
lngSU = .ScreenUpdating
.EnableEvents = 0
.ScreenUpdating = 0
.DisplayAlerts = 0
End With
Const RowsBlock As Long = 50000
If Right$(DB_FilePath, 1) <> Application.PathSeparator Then DB_FilePath = DB_FilePath & Application.PathSeparator
strExtn = LCase$(Right$(DB_Name, 4))
If strExtn = ".mdb" Then Flg = True
If Not Flg Then
strExtn = LCase$(Right$(DB_Name, 6))
If strExtn <> ".accdb" Then
MsgBox "Not a valid extension", vbCritical, strTitle
GoTo QuickExit
End If
End If
strDBFullName = DB_FilePath & DB_Name
If Not IsFileExists(strDBFullName) Then
MsgBox "DB " & strDBFullName & " doesn't exists", vbCritical, strTitle
GoTo QuickExit
End If
Set wbkActive = ThisWorkbook
strTempFPath = wbkActive.Path
If strTempFPath = vbNullString Then
strTempFPath = Environ$("Temp") & Application.PathSeparator
End If
On Error Resume Next
Set wksSource = wbkActive.Worksheets(CStr(xl_SheetName))
If Err.Number <> 0 Then
MsgBox "Worksheet '" & xl_SheetName & "' doesn't exists", vbInformation, strTitle
Err.Clear: On Error GoTo 0
GoTo QuickExit
End If
On Error GoTo 0
If Len(Trim$(DefinedRngName)) Then
If HeaderYes Then
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(Def inedRngName).Rows("2:2").SpecialCells(4)
On Error GoTo 0
Else
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(Def inedRngName).Rows("1:1").SpecialCells(4)
On Error GoTo 0
End If
If Not rngBlank Is Nothing Then
MsgBox "Range " & rngBlank.Address(0, 0) & vbLf & "Seem to be empty. It should not be empty", vbCritical, strTitle
GoTo QuickExit
End If
strDataRange = DefinedRngName
lngLastRow = Split(wbkActive.Worksheets(CStr(xl_SheetName)).Ran ge(strDataRange).Address, "$")(4)
ElseIf Len(Trim$(RangeAddress)) Then
If HeaderYes Then
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(Ran geAddress).Rows("2:2").SpecialCells(4)
On Error GoTo 0
Else
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(Ran geAddress).Rows("1:1").SpecialCells(4)
On Error GoTo 0
End If
If Not rngBlank Is Nothing Then
MsgBox "Range " & rngBlank.Address(0, 0) & vbLf & "Seem to be empty. It should not be empty", vbCritical, strTitle
GoTo QuickExit
End If
strDataRange = RangeAddress
lngLastRow = Split(wbkActive.Worksheets(CStr(xl_SheetName)).Ran ge(strDataRange).Address, "$")(4)
Else
With wksSource
lngLastRow = .Cells.Find(What:="*", after:=.Cells(1), lookat:=2, SearchOrder:=1, SearchDirection:=2).Row
lngLastCol = .Cells.Find(What:="*", after:=.Cells(1), lookat:=2, SearchOrder:=2, SearchDirection:=2).Column
Set rngFirstCell = .Cells.Find(What:="*", after:=.Cells(lngLastRow, lngLastCol), lookat:=2)
strAddress = rngFirstCell.CurrentRegion.Address
If InStr(1, strAddress, ":") = 0 Then
MsgBox "There is no data to be exported", vbCritical, "KnowledgeMine"
GoTo QuickExit
End If
lngLastCol = Range(CStr(Split(strAddress, ":")(1))).Column
lngLastRow = CLng(Split(strAddress, "$")(4))
.Range(rngFirstCell, .Cells(lngLastRow, lngLastCol)).Name = "DB_Range"
strDataRange = "DB_Range"
If HeaderYes Then
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(str DataRange).Rows("2:2").SpecialCells(4)
On Error GoTo 0
Else
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(str DataRange).Rows("1:1").SpecialCells(4)
On Error GoTo 0
End If
If Not rngBlank Is Nothing Then
MsgBox "Range " & rngBlank.Address(0, 0) & vbLf & "Seem to be empty. It should not be empty", vbCritical, strTitle
GoTo QuickExit
End If
End With
End If
Set rngFirstCell = Nothing
Hdr = wksSource.Range(CStr(strDataRange)).Rows(1)
Set wbkTemp = Workbooks.Add
If lngLastRow > 65535 Then
With wksSource
For lngLoop = 1 To 1 + (lngLastRow \ RowsBlock)
ReDim Preserve arrNameRanges(1 To lngLoop)
If lngLoop = 1 Then
lngEndRow = RowsBlock
lngStartRow = 1
lngRowsSoFar = RowsBlock
Set wksTemp = Nothing
Set wksTemp = wbkTemp.Worksheets.Add
.Range(.Cells(1), .Cells(lngEndRow, UBound(Hdr, 2))).Copy wksTemp.Range("a1")
wksTemp.UsedRange.Name = "Temp" & lngLoop
arrNameRanges(lngLoop) = "Temp" & lngLoop
Else
Set wksTemp = Nothing
Set wksTemp = wbkTemp.Worksheets.Add
lngStartRow = lngEndRow + 1
lngEndRow = Application.Min(RowsBlock, lngLastRow - lngEndRow)
lngEndRow = lngStartRow + lngEndRow
wksTemp.Range("a1").Resize(, UBound(Hdr, 2)).Value = Hdr
.Range(.Cells(lngStartRow, 1), .Cells(lngEndRow, UBound(Hdr, 2))).Copy wksTemp.Range("a2")
wksTemp.UsedRange.Name = "Temp" & lngLoop
arrNameRanges(lngLoop) = "Temp" & lngLoop
End If
Next
End With
Else
ReDim Preserve arrNameRanges(1 To 1)
arrNameRanges(1) = "Temp1"
wksSource.Range(CStr(strDataRange)).Copy wbkTemp.Worksheets(1).Range("a1")
wbkTemp.Worksheets(1).UsedRange.Name = arrNameRanges(1)
End If
wbkTemp.SaveAs strTempFPath & "_Temp_", 56 'xls
strTempFullName = wbkTemp.FullName
wbkTemp.Close 0
Set wbkTemp = Nothing
Set adoConn = CreateObject("ADODB.Connection")
If Flg Then
adoConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;data source=" & CStr(strDBFullName) & ";"
Else
adoConn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & CStr(strDBFullName) & ";"
End If
If TableProp = AppendTable Then
If ClearTable Then
On Error Resume Next
adoConn.Execute "DELETE * FROM " & Tbl_Name
On Error GoTo 0
End If
End If
For lngLoop = 1 To UBound(arrNameRanges)
If lngLoop = 1 Then
If TableProp = AppendTable Then
If Flg Then
If HeaderYes Then
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=Yes;]"
Else
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=No;]"
End If
Else
If HeaderYes Then
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=Yes;]"
Else
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=No;]"
End If
End If
Else
If Flg Then
On Error Resume Next
adoConn.Execute "DROP Table " & Tbl_Name
On Error GoTo 0
If HeaderYes Then
adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=Yes;]"
Else
adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=No;IMEX=1]"
End If
Else
On Error Resume Next
adoConn.Execute "DROP Table " & Tbl_Name
On Error GoTo 0
If HeaderYes Then
adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=Yes;]"
Else
adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=No;IMEX=1;]"
End If
End If
End If
Else
If Flg Then
If HeaderYes Then
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=Yes;]"
Else
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=No;]"
End If
Else
If HeaderYes Then
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=Yes;]"
Else
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=No;]"
End If
End If
End If
Next
Kill strTempFullName
If adoConn.State <> 0 Then adoConn.Close
Set adoConn = Nothing
Set wbkActive = Nothing
Set wksSource = Nothing
QuickExit:
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
End If
With Application
.EnableEvents = 1
.ScreenUpdating = lngSU
.DisplayAlerts = 1
End With
End Sub
Function IsFileExists(ByVal FilePath As String) As Boolean
IsFileExists = Len(Dir(FilePath, vbDirectory))
End Function
and call the sub like
Sub kTest()
ExportRangeIntoAccess "C:\ExcelFox", "Test_2007.accdb", "MyTable", "Sheet1", True, CreateTable, "A1:K200000", "", False
'ExportRangeIntoAccess "C:\ExcelFox", "Test_2007.accdb", "MyTable", "Sheet1", True, CreateTable, "MyRange", "", False
'ExportRangeIntoAccess "C:\ExcelFox", "Test_2007.accdb", "MyTable", "Sheet1", True, AppendTable, "A1:K200000", "", True
'ExportRangeIntoAccess "C:\ExcelFox", "Test_2003.mdb", "MyTable", "Sheet1", True, AppendTable, "A1:K20000", "", True
'ExportRangeIntoAccess "C:\ExcelFox", "Test_2003.mdb", "MyTable", "Sheet1", True, CreateTable, "A1:K20000", "", False
End Sub
Enjoy !
If you want to export a range of data into an Access table (Either before or 2007 or Post 2007), here is a sub. This also allows you to either create a new table or append an existing table.
Option Explicit
Public Enum TableProperty
AppendTable = 0
CreateTable = 1
End Enum
Private Const strTitle As String = "ExcelFox.com"
Sub ExportRangeIntoAccess(ByVal DB_FilePath As String, ByVal DB_Name As String, _
ByVal Tbl_Name As String, _
ByVal xl_SheetName As String, _
ByVal HeaderYes As Boolean, _
ByVal TableProp As TableProperty, _
Optional ByVal RangeAddress As String, _
Optional ByVal DefinedRngName As String, _
Optional ByVal ClearTable As Boolean = True)
Dim adoConn As Object
Dim wbkActive As Workbook
Dim wbkTemp As Workbook
Dim wksSource As Worksheet
Dim wksTemp As Worksheet
Dim rngFirstCell As Range
Dim strAddress As String
Dim strDataRange As String
Dim arrNameRanges() As String
Dim strTempFPath As String
Dim strTempFullName As String
Dim strDBFullName As String
Dim strExtn As String
Dim Hdr As Variant
Dim lngLoop As Long
Dim lngStartRow As Long
Dim lngEndRow As Long
Dim lngRowsSoFar As Long
Dim lngLastCol As Long
Dim lngLastRow As Long
Dim lngSU As Long
Dim Flg As Boolean
Dim rngBlank As Range
With Application
lngSU = .ScreenUpdating
.EnableEvents = 0
.ScreenUpdating = 0
.DisplayAlerts = 0
End With
Const RowsBlock As Long = 50000
If Right$(DB_FilePath, 1) <> Application.PathSeparator Then DB_FilePath = DB_FilePath & Application.PathSeparator
strExtn = LCase$(Right$(DB_Name, 4))
If strExtn = ".mdb" Then Flg = True
If Not Flg Then
strExtn = LCase$(Right$(DB_Name, 6))
If strExtn <> ".accdb" Then
MsgBox "Not a valid extension", vbCritical, strTitle
GoTo QuickExit
End If
End If
strDBFullName = DB_FilePath & DB_Name
If Not IsFileExists(strDBFullName) Then
MsgBox "DB " & strDBFullName & " doesn't exists", vbCritical, strTitle
GoTo QuickExit
End If
Set wbkActive = ThisWorkbook
strTempFPath = wbkActive.Path
If strTempFPath = vbNullString Then
strTempFPath = Environ$("Temp") & Application.PathSeparator
End If
On Error Resume Next
Set wksSource = wbkActive.Worksheets(CStr(xl_SheetName))
If Err.Number <> 0 Then
MsgBox "Worksheet '" & xl_SheetName & "' doesn't exists", vbInformation, strTitle
Err.Clear: On Error GoTo 0
GoTo QuickExit
End If
On Error GoTo 0
If Len(Trim$(DefinedRngName)) Then
If HeaderYes Then
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(Def inedRngName).Rows("2:2").SpecialCells(4)
On Error GoTo 0
Else
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(Def inedRngName).Rows("1:1").SpecialCells(4)
On Error GoTo 0
End If
If Not rngBlank Is Nothing Then
MsgBox "Range " & rngBlank.Address(0, 0) & vbLf & "Seem to be empty. It should not be empty", vbCritical, strTitle
GoTo QuickExit
End If
strDataRange = DefinedRngName
lngLastRow = Split(wbkActive.Worksheets(CStr(xl_SheetName)).Ran ge(strDataRange).Address, "$")(4)
ElseIf Len(Trim$(RangeAddress)) Then
If HeaderYes Then
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(Ran geAddress).Rows("2:2").SpecialCells(4)
On Error GoTo 0
Else
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(Ran geAddress).Rows("1:1").SpecialCells(4)
On Error GoTo 0
End If
If Not rngBlank Is Nothing Then
MsgBox "Range " & rngBlank.Address(0, 0) & vbLf & "Seem to be empty. It should not be empty", vbCritical, strTitle
GoTo QuickExit
End If
strDataRange = RangeAddress
lngLastRow = Split(wbkActive.Worksheets(CStr(xl_SheetName)).Ran ge(strDataRange).Address, "$")(4)
Else
With wksSource
lngLastRow = .Cells.Find(What:="*", after:=.Cells(1), lookat:=2, SearchOrder:=1, SearchDirection:=2).Row
lngLastCol = .Cells.Find(What:="*", after:=.Cells(1), lookat:=2, SearchOrder:=2, SearchDirection:=2).Column
Set rngFirstCell = .Cells.Find(What:="*", after:=.Cells(lngLastRow, lngLastCol), lookat:=2)
strAddress = rngFirstCell.CurrentRegion.Address
If InStr(1, strAddress, ":") = 0 Then
MsgBox "There is no data to be exported", vbCritical, "KnowledgeMine"
GoTo QuickExit
End If
lngLastCol = Range(CStr(Split(strAddress, ":")(1))).Column
lngLastRow = CLng(Split(strAddress, "$")(4))
.Range(rngFirstCell, .Cells(lngLastRow, lngLastCol)).Name = "DB_Range"
strDataRange = "DB_Range"
If HeaderYes Then
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(str DataRange).Rows("2:2").SpecialCells(4)
On Error GoTo 0
Else
On Error Resume Next
Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(str DataRange).Rows("1:1").SpecialCells(4)
On Error GoTo 0
End If
If Not rngBlank Is Nothing Then
MsgBox "Range " & rngBlank.Address(0, 0) & vbLf & "Seem to be empty. It should not be empty", vbCritical, strTitle
GoTo QuickExit
End If
End With
End If
Set rngFirstCell = Nothing
Hdr = wksSource.Range(CStr(strDataRange)).Rows(1)
Set wbkTemp = Workbooks.Add
If lngLastRow > 65535 Then
With wksSource
For lngLoop = 1 To 1 + (lngLastRow \ RowsBlock)
ReDim Preserve arrNameRanges(1 To lngLoop)
If lngLoop = 1 Then
lngEndRow = RowsBlock
lngStartRow = 1
lngRowsSoFar = RowsBlock
Set wksTemp = Nothing
Set wksTemp = wbkTemp.Worksheets.Add
.Range(.Cells(1), .Cells(lngEndRow, UBound(Hdr, 2))).Copy wksTemp.Range("a1")
wksTemp.UsedRange.Name = "Temp" & lngLoop
arrNameRanges(lngLoop) = "Temp" & lngLoop
Else
Set wksTemp = Nothing
Set wksTemp = wbkTemp.Worksheets.Add
lngStartRow = lngEndRow + 1
lngEndRow = Application.Min(RowsBlock, lngLastRow - lngEndRow)
lngEndRow = lngStartRow + lngEndRow
wksTemp.Range("a1").Resize(, UBound(Hdr, 2)).Value = Hdr
.Range(.Cells(lngStartRow, 1), .Cells(lngEndRow, UBound(Hdr, 2))).Copy wksTemp.Range("a2")
wksTemp.UsedRange.Name = "Temp" & lngLoop
arrNameRanges(lngLoop) = "Temp" & lngLoop
End If
Next
End With
Else
ReDim Preserve arrNameRanges(1 To 1)
arrNameRanges(1) = "Temp1"
wksSource.Range(CStr(strDataRange)).Copy wbkTemp.Worksheets(1).Range("a1")
wbkTemp.Worksheets(1).UsedRange.Name = arrNameRanges(1)
End If
wbkTemp.SaveAs strTempFPath & "_Temp_", 56 'xls
strTempFullName = wbkTemp.FullName
wbkTemp.Close 0
Set wbkTemp = Nothing
Set adoConn = CreateObject("ADODB.Connection")
If Flg Then
adoConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;data source=" & CStr(strDBFullName) & ";"
Else
adoConn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & CStr(strDBFullName) & ";"
End If
If TableProp = AppendTable Then
If ClearTable Then
On Error Resume Next
adoConn.Execute "DELETE * FROM " & Tbl_Name
On Error GoTo 0
End If
End If
For lngLoop = 1 To UBound(arrNameRanges)
If lngLoop = 1 Then
If TableProp = AppendTable Then
If Flg Then
If HeaderYes Then
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=Yes;]"
Else
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=No;]"
End If
Else
If HeaderYes Then
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=Yes;]"
Else
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=No;]"
End If
End If
Else
If Flg Then
On Error Resume Next
adoConn.Execute "DROP Table " & Tbl_Name
On Error GoTo 0
If HeaderYes Then
adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=Yes;]"
Else
adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=No;IMEX=1]"
End If
Else
On Error Resume Next
adoConn.Execute "DROP Table " & Tbl_Name
On Error GoTo 0
If HeaderYes Then
adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=Yes;]"
Else
adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=No;IMEX=1;]"
End If
End If
End If
Else
If Flg Then
If HeaderYes Then
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=Yes;]"
Else
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=No;]"
End If
Else
If HeaderYes Then
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=Yes;]"
Else
adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=No;]"
End If
End If
End If
Next
Kill strTempFullName
If adoConn.State <> 0 Then adoConn.Close
Set adoConn = Nothing
Set wbkActive = Nothing
Set wksSource = Nothing
QuickExit:
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
End If
With Application
.EnableEvents = 1
.ScreenUpdating = lngSU
.DisplayAlerts = 1
End With
End Sub
Function IsFileExists(ByVal FilePath As String) As Boolean
IsFileExists = Len(Dir(FilePath, vbDirectory))
End Function
and call the sub like
Sub kTest()
ExportRangeIntoAccess "C:\ExcelFox", "Test_2007.accdb", "MyTable", "Sheet1", True, CreateTable, "A1:K200000", "", False
'ExportRangeIntoAccess "C:\ExcelFox", "Test_2007.accdb", "MyTable", "Sheet1", True, CreateTable, "MyRange", "", False
'ExportRangeIntoAccess "C:\ExcelFox", "Test_2007.accdb", "MyTable", "Sheet1", True, AppendTable, "A1:K200000", "", True
'ExportRangeIntoAccess "C:\ExcelFox", "Test_2003.mdb", "MyTable", "Sheet1", True, AppendTable, "A1:K20000", "", True
'ExportRangeIntoAccess "C:\ExcelFox", "Test_2003.mdb", "MyTable", "Sheet1", True, CreateTable, "A1:K20000", "", False
End Sub
Enjoy !