der Name steht ja im Dateinamen, dann gehts so.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub importData()
Dim objADO As Object
Dim strPath As String, strFile As String, strName As String
Dim vntSheets As Variant
Dim lngIndex As Long, lngRow As Long, lngCount As Long
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
vntSheets = Array("Gennaio", "Febbraio", "Marzo", "Aprile", "Maggio", "Giugno", "Luglio", "Agosto", "Settembre", "Ottobre", "Novembre", "Dicembre")
With ThisWorkbook.Sheets("Liste")
.Range("A2:B" & .Rows.Count).ClearContents
strPath = ThisWorkbook.Path & "\Test\"
strFile = Dir(strPath & "*.xls*", vbNormal)
Do While strFile <> ""
strName = Trim$(Split(Split(strFile, "-")(1), ".")(0))
For lngIndex = 0 To UBound(vntSheets)
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Set objADO = ExcelTable(strPath & strFile, CStr(vntSheets(lngIndex)), "AK3:AK34")
lngCount = objADO.RecordCount
.Cells(lngRow, 2).CopyFromRecordset objADO
.Range(.Cells(lngRow, 1), .Cells(lngRow + lngCount, 1)) = strName
objADO.Close
Next
strFile = Dir
Loop
On Error Resume Next
.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Err.Clear
On Error GoTo ErrExit
End With
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'importData'" & 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 Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
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
Dim SQL As String
Dim Con As String
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