AW: Liste aus mehreren Dateien mit VBA erstellen
30.06.2015 21:41:41
Sepp
Hallo Roman,
folgender Code liest die Daten aus D10 aller xl-Dateien eines Verzeichnisses aus. Dabei wird immer das erste Tabellenblatt ausgelesen, egal welchen Namen es trägt. Die erste Datenzeile enthält die Überschrift aus C10.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub import()
Dim strPath As String, strFile As String, strTable As String
Dim lngI As Long, vntValues() As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "E:\Forum"
.Title = "Datenimport Ordnerauswahl"
.ButtonName = "Import Starten"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
End With
If Len(strPath) Then
strFile = Dir(strPath & "*.xls*", vbNormal)
Do While Len(strFile)
strTable = GetSheetNames(strPath & strFile)(0)
Redim Preserve vntValues(lngI)
If lngI = 0 Then
vntValues(lngI) = GetValue(strPath, strFile, strTable, "C10")
lngI = lngI + 1
Redim Preserve vntValues(lngI)
End If
vntValues(lngI) = GetValue(strPath, strFile, strTable, "D10")
lngI = lngI + 1
strFile = Dir
Loop
End If
If lngI > 0 Then
Cells(1, 1).Resize(UBound(vntValues) + 1, 1) = Application.Transpose(vntValues)
End If
End Sub
Private Function GetValue(path As String, file As String, sheet As String, ref As String) As Variant
Dim arg As String
On Error GoTo ErrExit
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
Exit Function
ErrExit:
GetValue = xlErrValue
End Function
Private Function GetSheetNames(ByVal FileName As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
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 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
Gruß Sepp