Importfunktion mit VBA

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Importfunktion mit VBA
von: Benjamin
Geschrieben am: 20.11.2015 13:37:27

Hallo VAB-Experten,
hatte mir vor einiger Zeit folgendes VBA für den Datenimport in Excel erstellt.


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
Aktuell hab ich nun das Problem, dass die Daten nicht entsprechend den Semicolon getrennt importiert wird, sondern alles in einer Spalte landet.
Wo liegt der Fehler?
Danke für Eure Hilfe
Grüße
Benjamin

Bild

Betrifft: AW: Importfunktion mit VBA
von: Daniel
Geschrieben am: 20.11.2015 14:04:50
Hi
was bei deinem Import auffällig ist, dass du zwar das deutsche Semikolon als Trennzeichen angibst, aber trotzdem mit dem Punkt das englische Dezimalzeichen verwenden willst.
wenn das tatsächlich korrekt ist, wäre die Erstellung der CSV-Datei inkonsequent.
schau dir die CSV-Datei mal mit einem Texteditor an und prüfe, wie die Datei tatsächlich aufgebaut ist.
durchgängig "deutsche" CSV-Dateien kann man auch normal mit Workbooks.Open öffnen, wenn man zusätzlich den Paramteter Local:=True angibt.
Gruß Daniel

Bild

Betrifft: AW: Importfunktion mit VBA
von: Benjamin
Geschrieben am: 20.11.2015 14:30:47
Hallo Daniel,
das mit dem Punkt bzw. Dezimalzeichen ist richtig.
Die csv-Dateien kommen aus diversen Maschinen. Somit kann ich das nicht beeinflussen.
Das eigentliche Problem ist, dass nicht mehrere Spalten angelegt werden sondern alles in eine wandert.
Hab nur sehr wenig Ahnung von VBA, aber wenn Du einen anderen Vorschlag hättest, würde ich das gerne ausprobieren.
Grüße
Benjamin

Bild

Betrifft: AW: Importfunktion mit VBA
von: Daniel
Geschrieben am: 20.11.2015 15:01:08
Hi
da ich deine Datei nicht kenne, kann ich dir da auch nicht sagen welches Trennzeichen du nehmen musst.
allerdings verwende ich für solche Importe nicht das Workbook-OpenText-Event.
da verwende ich für normale CSV-Dateien das Workbook.Open mit dem Zusatz Local:=True oder wenn ich spezielle Einstellungen machen will, die Importfunktion aus DATEN - EXTERNE DATEN - AUS TEXT.
die kannst du dir ja bei Bedarf mit dem Recorder aufzeichnen.
Gruß Daniel

Bild

Betrifft: AW: Importfunktion mit VBA
von: Benjamin
Geschrieben am: 20.11.2015 15:29:26
Hallo Daniel,
hatte es mit dem Recorder versucht. Bin aber leider daran gescheitert.
Hab unter nachfolgendem Link einige Bsp.-Daten hochgeladen.
https://www.herber.de/bbs/user/101679.zip
Ziel des Makros ist es, alle Daten über eine Mehrfachauswahl in eine Excel-Datei zu importieren.
Danke für deine Hilfe
Grüße
Benjamin

Bild

Betrifft: AW: Importfunktion mit VBA
von: Armin
Geschrieben am: 21.11.2015 15:47:13
Hallo Benjamin,
Deine csv-Daten entrechen nicht dem Standard. Du hast kein ordenliches Trennzeichen für einen Datensatz.
Das muss ein Carriage Return sein und nicht wie bei Dir ein Line Feed (Hex 0D und nicht 0A) ! Siehe Anhang. Auch csv-Dateien haben bestimmte Anforderungen.
Userbild
Gruß Armin

Bild

Betrifft: AW: Importfunktion mit VBA
von: Sepp
Geschrieben am: 21.11.2015 22:47:32
Hallo Benjamin,
probier mal folgenden Code (Tabellenname anpassen!).
Ich musste allerdings deine CSV's umbenennen, weil der Code mit deinen Dateinamen nicht zurecht kam!

' **********************************************************************
' 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

Gruß Sepp


Bild

Betrifft: Punkt in Dateinamen
von: Sepp
Geschrieben am: 22.11.2015 10:33:46
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


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Bedingte Formatierung etwas komplexer"