By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
429,251 Members | 2,760 Online
Bytes IT Community
Submit an Article
Got Smarts?
Share your bits of IT knowledge by writing an article on Bytes.

Multi-Import/Link Excel file into access with debug info and more option

100+
P: 215
After long time testing in my database, upgraded a lot of part from first code, I'm very happy to show everyone my Import/Link Excel vba code that can be very usefull and stable.

Function (not sub as I prefer call function in another function) ImportMultiData([Link])

Can import/Link excel table with additional option:
Option - Link - True = Link table, False = Import Table, default = False

And after 3 times trying to import/Link, Function will ignore that file and go next. It'll give detail information of Error Import file after Import/Link, ErrDebug.txt will be created automatically at desktop for the lastest importing error.

Auto repair broken Excel file with 2nd Function below this, called OpenExcelIdle()

Expand|Select|Wrap|Line Numbers
  1. Option Compare Database
  2. Option Explicit
  3. Public Function ImportMultiData(Optional Link as Boolean)
  4. 'Owner: Hv summer -
  5. 'Original code found at:
  6. 'https://bytes.com/topic/access/insights/964941-multi-import-link-excel-file-into-access-debug-info-more-option#post3798690
  7. 'If you want to use/share this Code, plz keep my signature, thanks. 
  8. 'Enjoy it.
  9. DoCmd.SetWarnings (False)
  10.  
  11. On Error GoTo Err_F::
  12. Dim strFolder As String, i As Integer, g As Integer, n As Integer, Try As Integer, TimesTry As Integer, M As Integer
  13. Dim blnHasFieldNames As Boolean
  14. Dim strFile As String, strArray() As String, strError As String, strErr As Integer, ListNameErr As String, ListErr As String
  15. Dim strTable As String
  16. Dim lngPos As Long
  17. Dim strExtension As String
  18. Dim lngFileType As Long
  19. Dim strFullFileName As String
  20. Dim ImportRange as String
  21. g = 0
  22.  
  23. 'Change this to False if you data's range in excel don't have Field Names
  24. blnHasFieldNames = True
  25.  
  26. 'Change this strTable to anytable name that you want to import
  27. strTable = "DataTable"
  28.  
  29. 'Change this ImportRange to wherever your data's range in excel
  30. ImportRange = "Data!B4:J64000"
  31.  
  32. if ismissing(Link) then Link = False
  33. With Application.FileDialog(3) ' msoFileDialogFilePicker
  34.          .InitialFileName = "D:\"
  35.         .AllowMultiSelect = True
  36.         .Title = "Select Excel Files to Import"
  37. If .Show Then
  38.     For i = 1 To .SelectedItems.Count
  39.  
  40.         strFullFileName = .SelectedItems(i)
  41.  
  42.         If Right$(strFullFileName, 1) <> "\" And Len(strFullFileName) > 0 Then
  43.             strArray = Split(strFullFileName, "\")
  44.             strFile = strArray(UBound(strArray))
  45.         End If
  46.  
  47.         lngPos = InStrRev(strFile, ".")
  48.         strExtension = Mid(strFile, lngPos + 1)
  49.         Select Case strExtension
  50.             Case "xls"
  51.                 lngFileType = acSpreadsheetTypeExcel9
  52.             Case "xlsx"
  53.                 lngFileType = acSpreadsheetTypeExcel12Xml
  54.             Case "xlsb", "xlsm"
  55.                 lngFileType = acSpreadsheetTypeExcel12
  56.         End Select
  57.         Try = 0
  58.         M = 0
  59. TryAgain::
  60.         If Try = 3 Then GoTo NextI::
  61.         If M > 0 Then Try = Try + 1
  62.         If Link = False then
  63.           DoCmd.TransferSpreadsheet acImport, lngFileType, strTable, strFullFileName, blnHasFieldNames, ImportRange
  64.         Else
  65.           DoCmd.TransferSpreadsheet acLink, lngFileType, strTable, strFullFileName, blnHasFieldNames, ImportRange        
  66.         End If
  67.         g = g + 1
  68.         If Try > 0 Then TimesTry = TimesTry + Try
  69. NextI::
  70.     Next i 'Move to the next file
  71.     If n > 0 Or TimesTry > 0 Then
  72.             MsgBox "Number of Files selected: " & .SelectedItems.Count & ". Number of Files Imported: " & g - n & ". Err Num:" & n & vbNewLine & strError & vbNewLine & "Tried Times: " & TimesTry & vbNewLine & ListNameErr, vbInformation, "Finish Import"
  73.     Else
  74.             MsgBox "Number of Files selected: " & .SelectedItems.Count & ". Number of Files Imported: " & g - n, vbInformation, "Finish Import"
  75.     End If
  76.  
  77.     If Not n = 0 Then
  78.         Dim TFS As Object
  79.         Set TFS = CreateObject("Scripting.fileSystemobject")
  80.         Dim textF As Object
  81.         If Len(Dir("D:\ErrDebug.txt")) <> 0 Then Kill "D:\ErrDebug.txt"
  82.         Set textF = TFS.createtextfile("D:\ErrDebug.txt")
  83.         Set textF = Nothing
  84.         Set TFS = Nothing
  85.         Open "D:\ErrDebug.txt" For Output As #1
  86.         Print #1, ListErr
  87.         Close #1
  88.         If Len(Dir(Environ("USERPROFILE") & "\Desktop\ErrDebug.txt")) <> 0 Then Kill Environ("USERPROFILE") & "\Desktop\ErrDebug.txt"
  89.         Name "D:\ErrDebug.txt" As Environ("USERPROFILE") & "\Desktop\ErrDebug.txt"
  90.     End If
  91.  
  92. Else
  93.         MsgBox "No file selected!", vbCritical
  94.         Exit Function
  95.     End If
  96. End With
  97.  
  98. DoCmd.SetWarnings (True)
  99.  
  100. Exit_F:
  101. Exit Function
  102. Err_F:
  103. n = n + 1
  104. M = M + 1
  105. Call OpenExcelIdle(strFullFileName, M)
  106.  
  107. DoCmd.SetWarnings (True)
  108. If strErr <> Err.Number Then
  109.     strError = strError & Err.Number & ", " & Err.Description & " "
  110.     strErr = Err.Number
  111. End If
  112. If M = 1 Then
  113. ListNameErr = ListNameErr & strFile & ", "
  114. ListErr = ListErr & strFullFileName & vbNewLine
  115. End If
  116. DoCmd.SetWarnings (False)
  117. Resume TryAgain::
  118. End Function
  119.  
  120. 'This code below is additional function (Required) to repair excel file automatically.
  121. Public Function OpenExcelIdle(strFullFileName As String, Optional TimesTry As Integer)
  122. On Error GoTo Err::
  123. Dim xlapp As Object
  124. Set xlapp = CreateObject("Excel.Application")
  125. Dim books As Object
  126. xlapp.EnableEvents = False
  127. xlapp.AutomationSecurity = 3
  128. xlapp.Visible = False
  129. xlapp.DisplayAlerts = False
  130. xlapp.screenupdating = False
  131. If TimesTry = 0 Or IsMissing(TimesTry) Then
  132.     xlapp.workbooks.Open strFullFileName
  133. Else
  134.     xlapp.workbooks.Open FileName:=strFullFileName, CorruptLoad:=1
  135. End If
  136.  
  137. Set books = xlapp.ActiveWorkBook
  138.  
  139. books.Save
  140. books.Close
  141. xlapp.Quit
  142. Exit_F::
  143. Exit Function
  144. Err::
  145.  
  146. xlapp.DisplayAlerts = True
  147. xlapp.screenupdating = True
  148. xlapp.Quit
  149. Set books = Nothing
  150. Set xlapp = Nothing
  151. Resume Exit_F::
  152. End Function
  153.  
  154.  
Nov 22 '15 #1
Share this Article
Share on Google+
7 Comments


zmbd
Expert Mod 5K+
P: 5,397
The double colon for the labels
"TryAgain::"
should be
"TryAgain:"

The colon is used as a multiple command separator; thus, the compiler is expecting a second statement following the label. Even though it may parse correctly, it requires the compiler to cycle thru the line an extra time.

I'll have to read thru the remaining code another day :)
Nov 22 '15 #2

100+
P: 215
@Zmbd: actually "tryagain::" will work as it should be
I did not use any "Name:" as shortcut ==
Nov 23 '15 #3

zmbd
Expert Mod 5K+
P: 5,397
I didn't say it would not work, nor that it is a shortcut.

What the compiler is seeing is:
TryAgain::
[Label name] [operations separator] [missing/null operation]
Tryagain ....... : ........ ?????

This is an unneeded overhead on the runtime compiler as it has to parse the line and then determine how to handle the missing operation. Removing the second colon will eliminate that overhead.
Nov 23 '15 #4

100+
P: 215
ok, Thank you, I use these Label Name as shortcut but I don't really study it, I just saw and reuse it :D
Nov 23 '15 #5

P: 6
may I ask his example file access
Thank you
Nov 23 '15 #6

100+
P: 215
0.0 you can copy that vba code into your new module, then modify the agrument as your need ==
Nov 23 '15 #7

P: 1
Thanks for the share.
Dec 22 '15 #8