Anpassung Importcode für Tabellen
15.01.2016 08:19:28
Bernd
mit dem nachfolgenden Code importiere ich diverse Exceltabellenblätter aus einer Quelldatei in vordefinierte Tabellenblätter in einer Zieldatei. Dabei wird zusätzlich noch der Quellpfad in die Zieltabelle reinkopiert.
Leider hat sich aber die technische Zulieferung geändert:
Ich erhalte nun keine Datei mehr mit mit einzelnen Tabellenblätter, sondern mehrere Dateien mi jeweils nur einem Tabellenblatt. Leider ändern sich auch noch die Dateinamen dieser Dateien jeden Tag, und zwar in der Form, dass ein Datum dem Dateinamen noch vorgagestellt wird (Syntax: JJJJ MM TT). Die Tabellenblätter sind jedoch eindeutig und ändern sich nicht!
Was ich nun gerne als Ergebnis hätte:
Ich würde gerne die 4 Dateien einlesen (Vorgabe des Kopierbereiches individuell im Code) und diese in vorgebene Tabellenblätter der Zieldatei reinkopieren (Vorgabe des Zielbereiches individuell im Code). Auf den Quellpfad möchte ich gerne verzichten, dass ist mittlerweile unnötig. Wo wird das im Code deaktiviert? Außerdem sollten in den Zieltabellenblättern keine Formeln gelöscht werden, die ich dort außerhalb des definierten Zielbereiches hinterlegt habe. Im Vergleich zur bisherigen Lösung soll also nicht eine Datei mit verschiedenen Tabellenblätten auf verschiedene Tabellen in der Zieldatei "verteilt" werden, sondern mehrere eindeutige Tabellen aus mehreren Quelltabellen sollen auf mehrere Tabellenblätter der Zieldatei verteilt werden.
Zusatzfrage:
Kann man eigentlich bei der Vorgabe von Quelltabellennamen auch mit Platzhaltern, wildcards arbeiten? Welche Syntax müsste man da gegebenenfalls verwenden?
Viele Grüße
Bernd
Sub Import_TEST()
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, lngR As Long, lngNext() As Long, lngCalc As Long
Dim vntRef(4) As String
Sheets("Übersicht").Select
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = -4135
.DisplayAlerts = False
End With
'### !!! ###
'Array für Tabellenname(n) und Bereich(e) - ZielTabelle$QuellTabelle$Importbereich
vntRef(0) = "C1_Original$C1$A1:Z200"
vntRef(1) = "C2_Original$C2$A1:Z100"
vntRef(2) = "C3_Original$C3$A1:F60"
vntRef(3) = "C4_Original$C4$A1:F100"
vntRef(4) = "C5_Original$C5$A1:Z200"
ReDim lngNext(UBound(vntRef))
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "d:\2015 "
.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
For lngI = 0 To UBound(vntFiles)
For lngR = 0 To UBound(vntRef)
With ThisWorkbook.Sheets(Split(vntRef(lngR), "$")(0))
If lngNext(lngR) = 0 Then
.UsedRange = ""
lngNext(lngR) = 2
End If
strPath = Mid(vntFiles(lngI), 1, InStrRev(vntFiles(lngI), "\") - 1)
strFile = Mid(vntFiles(lngI), InStrRev(vntFiles(lngI), "\") + 1)
DoEvents
Application.StatusBar = "Import aus '" & strPath & "' - Datei: '" & strFile & "' - ( " & _
lngI + 1 & " von " & UBound(vntFiles) + 1 & " )" & " Aus Tabelle: '" & Split(vntRef(lngR), _
"$")(1) & "' - ( " & lngR + 1 & " von " & UBound(vntRef) + 1 & " )"
DoEvents
Set objADO = ExcelTable(vntFiles(lngI), CStr(Split(vntRef(lngR), "$")(1)), _
CStr(Split(vntRef(lngR), "$")(2)))
If lngI = 0 Then
For lngN = 1 To objADO.Fields.Count
.Cells(1, lngN) = objADO.Fields.Item(lngN - 1).Name
Next
.Cells(1, lngN) = "Aus Datei"
Else
lngN = objADO.Fields.Count + 1
End If
.Cells(lngNext(lngR), 1).CopyFromRecordset objADO
.Cells(lngNext(lngR), lngN).Resize(objADO.RecordCount, 1) = vntFiles(lngI)
.Cells(lngNext(lngR), lngN).Hyperlinks.Add anchor:=.Cells(lngNext(lngR), lngN), _
Address:=vntFiles(lngI), SubAddress:=""
lngNext(lngR) = lngNext(lngR) + objADO.RecordCount
objADO.Close
Set objADO = Nothing
.Columns.AutoFit
End With
Next
Next
MsgBox "Import aus " & IIf(UBound(vntFiles) = 0, "einer Datei", _
UBound(vntFiles) + 1 & " Dateien") & " und jeweils " & UBound(vntRef) + 1 & _
" Tabellen 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 FileExists(FileName As String) As Boolean
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
FileExists = objFSO.FileExists(FileName)
Set objFSO = Nothing
End Function