AW: Mehrere Textdateien in Arbeitsmappe importiere
10.03.2015 11:20:24
fcs
Hallo Minion.
entweder hast du in den Dateinamen Sonderzeichen, die für Blattnamen nicht zulässig sind oder die Dateinamen sind länger als 31 Zeichen.
Ich mal eine Korrektur eingebaut, die den Dateinamen auf Eignung als Blattname prüft und ggf. eine manuelle Korrektur abfragt.
Gruß
Franz
Sub import_Tabellen()
Dim strPfad As String
Dim FSO As Object
Dim file
Dim strBlattname As String
On Error GoTo Fehler
strPfad = "G:\...\"
' strPfad = "C:\Users\Public\Test\ABC\"
strPfad = "D:\Test\ABC\"
Application.ScreenUpdating = False
Set FSO = CreateObject("scripting.filesystemobject")
For Each file In FSO.getfolder(strPfad).Files
strBlattname = fncSheetName(Left(file.Name, InStrRev(file.Name, ".") - 1))
If strBlattname "" Then
ActiveSheet.Name = strBlattname
End If
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strPfad & file.Name, Destination:=Range("A1"))
.Name = "Datenauswertung"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next_File:
ActiveWorkbook.Worksheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Next
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Application.ScreenUpdating = True
End Sub
Function fncSheetName(ByVal strText As String, Optional ByVal strReplace As String = "_", _
Optional wkb As Workbook) As String
Dim intZeichen
Dim arrZeichen
Dim strName As String
Dim wks As Object
On Error GoTo Fehler
arrZeichen = Array(":", "\", "/", "?", "*", "[", "]")
If wkb Is Nothing Then Set wkb = ActiveWorkbook
strName = strText
Name_pruefen:
'unzulässige Zeichen im Blattnamen
For intZeichen = LBound(arrZeichen) To UBound(arrZeichen)
strName = VBA.Replace(strName, arrZeichen(intZeichen), strReplace)
Next
'Name einkürzen auf 31 zeichen
If Len(strName) > 31 Then
strName = Left(strName, 31)
End If
fncSheetName = strName
Set wks = wkb.Sheets(strName)
If Not wks Is Nothing Then
strName = InputBox("Der Blattname """ & strName & """ existiert bereits" & vbLf _
& "Bitte Name anpassen (max. Länge 31 zeichen", _
"Name für Blatt = Dateiname", strName)
If strName = "" Then
'der automatish generierte Blattname wird nicht verändert
fncSheetName = ""
Else
GoTo Name_pruefen
End If
End If
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0
Case 9 'Blattname ist noch nicht vorhanden
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
fncSheetName = ""
End Select
End With
End Function