Importfunktion mit VBA

Sub DateiMehrfachAuswahl() Dim vntPathAndFileNames As Variant Dim lngI As Long Dim wbkZiel As Workbook Dim wksZiel As Worksheet, wksText As Worksheet, intFehler As Integer On Error GoTo Fehler Set wbkZiel = ActiveWorkbook 'Importfunktion vntPathAndFileNames = Application.GetOpenFilename( _ fileFilter:="Text Files (*.csv), *.csv", _ Title:="Bitte wählen Sie die zu ladende Datei/en aus!", _ MultiSelect:=True) If VarType(vntPathAndFileNames) = vbBoolean Then MsgBox "Sie haben abgebrochen." Else For lngI = 1 To UBound(vntPathAndFileNames) Workbooks.OpenText Filename:=vntPathAndFileNames(lngI), _ Origin:=xlWindows, _ StartRow:=1, _ DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, _ Tab:=False, _ Semicolon:=True, _ Comma:=False, _ Space:=False, _ Other:=False, _ FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _ DecimalSeparator:=".", _ ThousandsSeparator:="," 'Dezimaltrennzeichen von Punkt in Komma geändert intFehler = 1 ActiveWorkbook.Worksheets(1).Move before:=wbkZiel.Worksheets(1) GoTo Weiter02 Weiter01: Set wksText = ActiveSheet Set wksZiel = wbkZiel.Worksheets.Add(before:=wbkZiel.Worksheets(1)) wksText.UsedRange.Copy wksZiel.Cells(1, 1) wksZiel.Name = wksText.Name wksText.Activate ActiveWorkbook.Close savechanges:=False Weiter02: Next End If Fehler: With Err Select Case .Number Case 0 'Alles OK Case 1004 If intFehler = 1 Then 'Tabellen nicht kompatibel für Verschieben intFehler = 0 Resume Weiter01 Else MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description End If Case Else MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description End Select End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

' ********************************************************************** ' Modul: Modul4 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub importCSV() Dim objADO As Object, objRS As Object Dim strPath As String, strFile As String, strSQL As String Dim vntItem As Variant Dim vntFiles() As String Dim lngI As Long, lngC As Long, lngN As Long With Application.FileDialog(msoFileDialogFilePicker) .InitialFileName = "E:\Forum" 'Startverzeichnis - Anpassen! .Title = "Datei auswählen" .ButtonName = "Import Starten" .AllowMultiSelect = True .Filters.Clear .Filters.Add "Text Dateien", "*.txt; *.csv", 1 .Filters.Add "Alle Dateien", "*.*", 2 .FilterIndex = 1 .InitialView = msoFileDialogViewList If .Show = -1 Then Redim vntFiles(.SelectedItems.Count - 1) For Each vntItem In .SelectedItems vntFiles(lngC) = vntItem lngC = lngC + 1 Next End If End With If lngC > 0 Then lngN = 2 For lngC = 0 To UBound(vntFiles) strPath = Mid(vntFiles(lngC), 1, InStrRev(vntFiles(lngC), "\")) strFile = Mid(vntFiles(lngC), InStrRev(vntFiles(lngC), "\") + 1) If Len(strFile) Then With Sheets("Tabelle1") 'Tabellenname - Anpassen! If MakeSchemaINI(strFile, strPath) Then Set objADO = CreateObject("ADODB.CONNECTION") objADO.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & strPath & _ "; Extended Properties=""text; HDR=Yes; FMT=Delimited; IMEX=1;""" Set objRS = CreateObject("ADODB.RECORDSET") strSQL = "SELECT * FROM [" & strFile & "]" objRS.Open strSQL, objADO, 3, 1, 1 If Not objRS.EOF Then If lngC = 0 Then For lngI = 1 To objRS.Fields.Count .Cells(1, lngI) = objRS.Fields(lngI - 1).Name Next End If .Cells(lngN, 1).CopyFromRecordset objRS lngN = lngN + objRS.RecordCount End If objRS.Close objADO.Close End If End With End If Next End If Set objADO = Nothing Set objRS = Nothing End Sub Private Function MakeSchemaINI(FileName As String, Path As String) As Boolean Dim strFile As String, strText As String Dim ff As Integer MakeSchemaINI = True On Error GoTo ErrExit If Right(Path, 1) <> "\" Then Path = Path & "\" strFile = Path & "Schema.ini" strText = "[" & FileName & "]" & vbCrLf & _ "Format=Delimited(;)" & vbCrLf & _ "DecimalSymbol=." & vbCrLf & _ "ColNameHeader=True" & vbCrLf & _ "MaxScanRows=0" & vbCrLf & _ "CharacterSet=ANSI" & vbCrLf & _ "Col1=""Drehmoment (N#m)"" Double" & vbCrLf & _ "Col2=""Drehwinkel (Deg)"" Double" & vbCrLf & _ "Col3=""Curve ID"" Long" ff = FreeFile Open strFile For Output As #ff Print #ff, strText; Close #ff Exit Function ErrExit: MakeSchemaINI = False End Function

Hallo Benjamin,
so geht es auch mit deinen Dateinamen (der . im Namen kann von SQL nicht verarbeitet werden).

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub importCSV()
Dim objADO As Object, objRS As Object
Dim strPath As String, strFile As String, strSQL As String
Dim vntItem As Variant
Dim vntFiles() As String, vntFiles2() As String, strName As String, strExt As String
Dim lngI As Long, lngC As Long, lngN As Long

With Application.FileDialog(msoFileDialogFilePicker)
  .InitialFileName = "E:\Forum" 'Startverzeichnis - Anpassen!
  .Title = "Datei auswählen"
  .ButtonName = "Import Starten"
  .AllowMultiSelect = True
  .Filters.Clear
  .Filters.Add "Text Dateien", "*.txt; *.csv", 1
  .Filters.Add "Alle Dateien", "*.*", 2
  .FilterIndex = 1
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    Redim vntFiles(.SelectedItems.Count - 1)
    For Each vntItem In .SelectedItems
      vntFiles(lngC) = vntItem
      lngC = lngC + 1
    Next
  End If
End With

If lngC > 0 Then
  'Punkte im Dateinamen entfernen weil SQL damit nicht umgehen kann
  'Die Dateien werden unter anderem Namen als Kopie gespeichert und am Ende wieder gelöscht
  Redim vntFiles2(UBound(vntFiles))
  For lngC = 0 To UBound(vntFiles)
    strExt = Mid(vntFiles(lngC), InStrRev(vntFiles(lngC), "."))
    strName = Left(vntFiles(lngC), Len(vntFiles(lngC)) - Len(strExt))
    strName = Replace(strName, ".", "_") & "_copy" & strExt
    vntFiles2(lngC) = strName
    FileCopy vntFiles(lngC), vntFiles2(lngC)
  Next
  
  lngN = 2
  For lngC = 0 To UBound(vntFiles)
    strPath = Mid(vntFiles2(lngC), 1, InStrRev(vntFiles2(lngC), "\"))
    strFile = Mid(vntFiles2(lngC), InStrRev(vntFiles2(lngC), "\") + 1)
    
    If Len(strFile) Then
      With Sheets("Tabelle1") 'Tabellenname - Anpassen!
        If MakeSchemaINI(strFile, strPath) Then
          Set objADO = CreateObject("ADODB.CONNECTION")
          objADO.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & strPath & _
            "; Extended Properties=""text; HDR=Yes; FMT=Delimited; IMEX=1;"""
          
          Set objRS = CreateObject("ADODB.RECORDSET")
          
          strSQL = "SELECT * FROM [" & strFile & "]"
          
          objRS.Open strSQL, objADO, 3, 1, 1
          
          If Not objRS.EOF Then
            If lngC = 0 Then
              For lngI = 1 To objRS.Fields.Count
                .Cells(1, lngI) = objRS.Fields(lngI - 1).Name
              Next
            End If
            .Cells(lngN, 1).CopyFromRecordset objRS
            lngN = lngN + objRS.RecordCount
          End If
          objRS.Close
          objADO.Close
          Kill strPath & "Schema.ini"
        End If
      End With
    End If
  Next
  
  'Kopien der Dateien löschen
  For lngC = 0 To UBound(vntFiles2)
    Kill vntFiles2(lngC)
  Next
End If


Set objADO = Nothing
Set objRS = Nothing
End Sub

Private Function MakeSchemaINI(FileName As String, Path As String) As Boolean
Dim strFile As String, strText As String
Dim ff As Integer

MakeSchemaINI = True

On Error GoTo ErrExit

If Right(Path, 1) <> "\" Then Path = Path & "\"

strFile = Path & "Schema.ini"

strText = "[" & FileName & "]" & vbCrLf & _
  "Format=Delimited(;)" & vbCrLf & _
  "DecimalSymbol=." & vbCrLf & _
  "ColNameHeader=True" & vbCrLf & _
  "MaxScanRows=0" & vbCrLf & _
  "CharacterSet=ANSI" & vbCrLf & _
  "Col1=""Drehmoment (N#m)"" Double" & vbCrLf & _
  "Col2=""Drehwinkel (Deg)"" Double" & vbCrLf & _
  "Col3=""Curve ID"" Long"

ff = FreeFile

Open strFile For Output As #ff
Print #ff, strText;
Close #ff

Exit Function

ErrExit:
MakeSchemaINI = False
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread