Option Explicit
Public Enum TableProperty
AppendTable = 0
CreateTable = 1
End Enum
Private Const strTitle As String = "FGC Securities LLC"
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 rngBlank As Range
With Application
lngSU = .ScreenUpdating
.EnableEvents = 0
.ScreenUpdating = 0
.DisplayAlerts = 0
End With
Const RowsBlock As Long = 50000
'Check if DB Exists
If Right$(DB_FilePath, 1) <> Application.PathSeparator Then DB_FilePath = DB_FilePath & Application.PathSeparator
strExtn = LCase$(Right$(DB_Name, 6))
If strExtn <> ".accdb" Then
MsgBox "Not a valid extension", vbCritical, strTitle
GoTo QuickExit
End If
strDBFullName = DB_FilePath & DB_Name
If Not IsFileExists(strDBFullName) Then
MsgBox "DB " & strDBFullName & " doesn't exists", vbCritical, strTitle
GoTo QuickExit
End If
'Check if Worksheet Exists
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
strDataRange = DefinedRngName
lngLastRow = Split(wbkActive.Worksheets(CStr(xl_SheetName)).Range(strDataRange).Address, "$")(4)
ElseIf Len(Trim$(RangeAddress)) Then
strDataRange = RangeAddress
lngLastRow = Split(wbkActive.Worksheets(CStr(xl_SheetName)).Range(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"
End With
End If
'Extract Data from workbook
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
'Connect to DB
Set adoConn = CreateObject("ADODB.Connection")
adoConn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & CStr(strDBFullName) & ";"
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 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
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
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
