Leerzeilen werden von meinem Code schon eliminiert, wahrscheinlich sind Leerzeichen und/oder unsichtbare Steuerzeichen im Spiel.
Sub importData()
Dim objADO As Object
Dim strPath As String, strFile As String, strName As String
Dim vntSheets As Variant, rng As Range, rngDel As Range
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
For Each rng In .Range("B1:B" & lngRow + lngCount)
If Len(Trim(Application.Clean(rng))) = 0 Then
If rngDel Is Nothing Then
Set rngDel = rng.EntireRow
Else
Set rngDel = Union(rngDel, rng.EntireRow)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
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