Import Code/ Frage
20.12.2018 11:58:29
Bernd
zu folgendem Code von "Sepp" habe ich eine Frage:
Die Tabellenblätter aus anderen Dateien werden anstandslos importiert, sofern es klassische Tabelle mit Spaltenköpfen sind. Sobald aber z. B. Textpassagen wie Überschriften in den Quelldaten enthalten sind , werden diese nicht zuverlässig oder sogar gar nicht übernommen. Auch bei Leerzellen wird gerne ein "K" eingetragen.In den Spaltenköpfen tauchen auch "#" auf.
Kann man diesen Bereich des Codes noch verbessern? Originalformatierung muss nicht unbedingt sein, aber "Vollständigkeit" wäre schon schön!
Danke und Gruß
Bernd
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub import()
Dim objADO As Object
Dim vntItem As Variant
Dim vntFiles() As String, strTable As String, strFile As String, strPath As String
Dim lngI As Long, lngN As Long, lngNext As Long, lngCalc As Long
Const cstrRef As String = "A1:AM6000" 'Importbereich
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = -4135
.DisplayAlerts = False
End With
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "E:\Forum" 'Startverzeichnis
.Title = "Dateien zum Import auswählen"
.ButtonName = "Import Starten"
.InitialView = msoFileDialogViewList
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel Dateien", "*.xls; *.xlsx; *.xlsm", 1
.Filters.Add "Alle Dateien", "*.*", 2
.FilterIndex = 1
If .Show = -1 Then
Redim vntFiles(.SelectedItems.Count - 1)
For Each vntItem In .SelectedItems
vntFiles(lngI) = vntItem
lngI = lngI + 1
Next
End If
End With
If lngI > 0 Then
With ThisWorkbook.Sheets("Tabelle1") 'Name der Tabelle in dieser Datei - anpassen!
.Range("A1:AN" & .Rows.Count) = ""
lngNext = 2
For lngI = 0 To UBound(vntFiles)
DoEvents
strPath = Mid(vntFiles(lngI), 1, InStrRev(vntFiles(lngI), "\") - 1)
strFile = Mid(vntFiles(lngI), InStrRev(vntFiles(lngI), "\") + 1)
Application.StatusBar = "Import aus '" & strPath & "' - Datei: '" & strFile & _
"' - ( " & lngI + 1 & " von " & UBound(vntFiles) + 1 & " )"
DoEvents
strTable = GetSheetNames(vntFiles(lngI))(0)
Set objADO = ExcelTable(vntFiles(lngI), strTable, cstrRef)
If lngI = 0 Then
For lngN = 1 To objADO.Fields.Count
.Cells(1, lngN) = objADO.Fields.Item(lngN - 1).Name
Next
End If
.Cells(lngNext, 1).CopyFromRecordset objADO
.Cells(lngNext, 40).Resize(objADO.RecordCount, 1) = vntFiles(lngI)
lngNext = lngNext + objADO.RecordCount
objADO.Close
Next
.Columns.AutoFit
End With
MsgBox "Import aus " & IIf(UBound(vntFiles) = 0, "einer Datei", UBound(vntFiles) + 1 & " Dateien") & _
" erfolgreich abgeschloßen!", vbInformation
End If
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'import'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - import"
.Clear
End If
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.StatusBar = False
End With
On Error GoTo 0
Set objADO = Nothing
End Sub
Private Function ExcelTable(ByRef Path As String, ByRef Table As String, ByRef SourceRange As _
String, Optional WhereString As String = "") As Object
' requires the function FileExists()
Dim SQL As String
Dim Con As String
If Not FileExists(Path) Then Exit Function
SQL = "select * from [" & Table & "$" & SourceRange & "] " & WhereString
If Mid(Path, InStrRev(Path, ".") + 1) = "xls" Then
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & Path & ";"
ElseIf Mid(Path, InStrRev(Path, ".") + 1) Like "xls?" Then
Con = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Extended Properties=""Excel 12.0;HDR=YES"";" _
& "Data Source=" & Path & ";"
Else
Exit Function
End If
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 3, 1
End Function
Private Function GetSheetNames(ByVal FileName As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
' requires the function FileExists()
Dim objADO_Connection As Object, objADO_Catalog As Object, objADO_Tables As Object
Dim lngIndex As Long, intLength As Integer, intPos As Integer, intStart As Integer
Dim strConString As String, strTable As String
Dim vntTmp() As Variant
If Not FileExists(FileName) Then
GetSheetNames = 0
Exit Function
End If
If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
"Data Source=" & FileName & ";"
ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR= _
YES"";" _
& "Data Source=" & FileName & ";"
Else
Exit Function
End If
Set objADO_Connection = CreateObject("ADODB.Connection")
objADO_Connection.Open strConString
Set objADO_Catalog = CreateObject("ADOX.Catalog")
Set objADO_Catalog.ActiveConnection = objADO_Connection
For Each objADO_Tables In objADO_Catalog.Tables
strTable = objADO_Tables.Name
intLength = Len(strTable)
intPos = 0
intStart = 1
'Worksheet name with embedded spaces enclosed by single quotes
If Left(strTable, 1) = "'" And Right(strTable, 1) = "'" Then
intPos = 1
intStart = 2
End If
'Worksheet names always end in the "$" character
If Mid$(strTable, intLength - intPos, 1) = "$" Then
Redim Preserve vntTmp(lngIndex)
vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
lngIndex = lngIndex + 1
End If
Next objADO_Tables
If lngIndex > 0 Then GetSheetNames = vntTmp
objADO_Connection.Close
Set objADO_Catalog = Nothing
Set objADO_Connection = Nothing
End Function
Private Function FileExists(FileName As String) As Boolean
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
FileExists = objFSO.FileExists(FileName)
Set objFSO = Nothing
End Function