Anzeige
Archiv - Navigation
1432to1436
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Excel-Datei einlesen
02.07.2015 17:10:41
Bernd
Hallo zusammen,
ich würde gerne, möglichst über ein Makro mit Auswahldialog, mehrere Exceldateien nacheinander in eine Excel-Zieldatei einlesen. Der einzulesende Bereich umfasst bei jeder Einlesedatei die Spalten A-AM und maximal die Zeilen 1-6000. In der Zieldatei sollten dann die Usprungsdaten ohne Leerzeilen aufgelistet sein, in der Spalte AN außerdem pro Zeile die Datenherkunft in Form des Dateinamens der Ursprungsdatei erzeugt werden.
Vielen Dank im Voraus schon mal für konstruktive Vorschläge!
Bernd

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel-Datei einlesen
02.07.2015 19:38:48
Sepp
Hallo Bernd,
haben die Daten Überschriften in Zeile 1?
Gruß Sepp

AW: Excel-Datei einlesen
02.07.2015 20:49:51
Bernd
Hallo Sepp,
ja, sorry, hatte ich vergessen zu erwähnen! Sind in allen Dateien identisch!
Viele Grüße
Bernd

AW: Excel-Datei einlesen
02.07.2015 21:06:00
Sepp
Hallo Bernd,
in ein allgemeines Modul der Zusammenfassungs-Datei.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub import()
  Dim objADO As Object
  Dim vntItem As Variant
  Dim vntFiles() As String, strTable As String, strFile As String, strPath As String
  Dim lngI As Long, lngN As Long, lngNext As Long, lngCalc As Long
  
  Const cstrRef As String = "A1:AM6000" 'Importbereich
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = -4135
    .DisplayAlerts = False
  End With
  
  With Application.FileDialog(msoFileDialogFilePicker)
    .InitialFileName = "E:\Forum" 'Startverzeichnis
    .Title = "Dateien zum Import auswählen"
    .ButtonName = "Import Starten"
    .InitialView = msoFileDialogViewList
    .AllowMultiSelect = True
    .Filters.Clear
    .Filters.Add "Excel Dateien", "*.xls; *.xlsx; *.xlsm", 1
    .Filters.Add "Alle Dateien", "*.*", 2
    .FilterIndex = 1
    If .Show = -1 Then
      Redim vntFiles(.SelectedItems.Count - 1)
      For Each vntItem In .SelectedItems
        vntFiles(lngI) = vntItem
        lngI = lngI + 1
      Next
    End If
  End With
  
  If lngI > 0 Then
    With ThisWorkbook.Sheets("Tabelle1") 'Name der Tabelle in dieser Datei - anpassen!
      .Range("A1:AM" & .Rows.Count) = ""
      For lngI = 0 To UBound(vntFiles)
        DoEvents
        strPath = Mid(vntFiles(lngI), 1, InStrRev(vntFiles(lngI), "\") - 1)
        strFile = Mid(vntFiles(lngI), InStrRev(vntFiles(lngI), "\") + 1)
        Application.StatusBar = "Import aus '" & strPath & "' - Datei: '" & strFile & _
          "' - ( " & lngI + 1 & " von " & UBound(vntFiles) + 1 & " )"
        DoEvents
        lngNext = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
        strTable = GetSheetNames(vntFiles(lngI))(0)
        Set objADO = ExcelTable(vntFiles(lngI), strTable, cstrRef)
        If lngI = 0 Then
          For lngN = 1 To objADO.Fields.Count
            .Cells(1, lngN) = objADO.Fields.Item(lngN - 1).Name
          Next
        End If
        .Cells(lngNext, 1).CopyFromRecordset objADO
        .Cells(lngNext, 40).Resize(objADO.RecordCount, 1) = vntFiles(lngI)
        objADO.Close
      Next
      .Columns.AutoFit
    End With
    MsgBox "Import aus " & IIf(UBound(vntFiles) = 0, "einer Datei", UBound(vntFiles) + 1 & " Dateien") & _
      " erfolgreich abgeschloßen!", vbInformation
  End If
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'import'" & 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 Prozedur - import"
      .Clear
    End If
  End With
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
  On Error GoTo 0
  
  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


Private Function GetSheetNames(ByVal FileName As String) As Variant
  'original by Bob Phillips, adapted by j.ehrensberger
  Dim objADO_Connection As Object, objADO_Catalog As Object, objADO_Tables As Object
  Dim lngIndex As Long, intLength As Integer, intPos As Integer, intStart As Integer
  Dim strConString As String, strTable As String
  Dim vntTmp() As Variant
  
  If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
    strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
      "Data Source=" & FileName & ";"
  ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
    strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" _
      & "Data Source=" & FileName & ";"
  Else
    Exit Function
  End If
  
  Set objADO_Connection = CreateObject("ADODB.Connection")
  objADO_Connection.Open strConString
  Set objADO_Catalog = CreateObject("ADOX.Catalog")
  Set objADO_Catalog.ActiveConnection = objADO_Connection
  
  For Each objADO_Tables In objADO_Catalog.Tables
    strTable = objADO_Tables.Name
    intLength = Len(strTable)
    intPos = 0
    intStart = 1
    'Worksheet name with embedded spaces enclosed by single quotes
    If Left(strTable, 1) = "'" And Right(strTable, 1) = "'" Then
      intPos = 1
      intStart = 2
    End If
    'Worksheet names always end in the "$" character
    If Mid$(strTable, intLength - intPos, 1) = "$" Then
      Redim Preserve vntTmp(lngIndex)
      vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
      lngIndex = lngIndex + 1
    End If
  Next objADO_Tables
  
  If lngIndex > 0 Then GetSheetNames = vntTmp
  
  objADO_Connection.Close
  Set objADO_Catalog = Nothing
  Set objADO_Connection = Nothing
  
End Function


Gruß Sepp

Anzeige
AW: Excel-Datei einlesen
02.07.2015 23:20:33
Bernd
Hallo Sepp,
das Einlesen einer Datei klappt hervorragend. Beim Einlesen der 2. Datei werden leider die Importzeilen der 1. Datei überschrieben. Lässt sich das noch beheben oder ist das deutlich komplexer?
Viele Grüße
Bernd

AW: Excel-Datei einlesen
02.07.2015 23:30:38
Sepp
Hallo Bernd,
dann sind deine Daten nicht konsistent, das heißt, deine erste Spalte ist leer und eben diese hatte ich zur Ermittlung der nächsten Startzeile herangezogen. Ist aber kein Problem, ich nehme nun die Anzahl der Daten jedes Importes als Grundlage.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub import()
  Dim objADO As Object
  Dim vntItem As Variant
  Dim vntFiles() As String, strTable As String, strFile As String, strPath As String
  Dim lngI As Long, lngN As Long, lngNext As Long, lngCalc As Long
  
  Const cstrRef As String = "A1:AM6000" 'Importbereich
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = -4135
    .DisplayAlerts = False
  End With
  
  With Application.FileDialog(msoFileDialogFilePicker)
    .InitialFileName = "E:\Forum" 'Startverzeichnis
    .Title = "Dateien zum Import auswählen"
    .ButtonName = "Import Starten"
    .InitialView = msoFileDialogViewList
    .AllowMultiSelect = True
    .Filters.Clear
    .Filters.Add "Excel Dateien", "*.xls; *.xlsx; *.xlsm", 1
    .Filters.Add "Alle Dateien", "*.*", 2
    .FilterIndex = 1
    If .Show = -1 Then
      Redim vntFiles(.SelectedItems.Count - 1)
      For Each vntItem In .SelectedItems
        vntFiles(lngI) = vntItem
        lngI = lngI + 1
      Next
    End If
  End With
  
  If lngI > 0 Then
    With ThisWorkbook.Sheets("Tabelle1") 'Name der Tabelle in dieser Datei - anpassen!
      .Range("A1:AN" & .Rows.Count) = ""
      lngNext = 2
      For lngI = 0 To UBound(vntFiles)
        DoEvents
        strPath = Mid(vntFiles(lngI), 1, InStrRev(vntFiles(lngI), "\") - 1)
        strFile = Mid(vntFiles(lngI), InStrRev(vntFiles(lngI), "\") + 1)
        Application.StatusBar = "Import aus '" & strPath & "' - Datei: '" & strFile & _
          "' - ( " & lngI + 1 & " von " & UBound(vntFiles) + 1 & " )"
        DoEvents
        strTable = GetSheetNames(vntFiles(lngI))(0)
        Set objADO = ExcelTable(vntFiles(lngI), strTable, cstrRef)
        If lngI = 0 Then
          For lngN = 1 To objADO.Fields.Count
            .Cells(1, lngN) = objADO.Fields.Item(lngN - 1).Name
          Next
        End If
        .Cells(lngNext, 1).CopyFromRecordset objADO
        .Cells(lngNext, 40).Resize(objADO.RecordCount, 1) = vntFiles(lngI)
        lngNext = lngNext + objADO.RecordCount
        objADO.Close
      Next
      .Columns.AutoFit
    End With
    MsgBox "Import aus " & IIf(UBound(vntFiles) = 0, "einer Datei", UBound(vntFiles) + 1 & " Dateien") & _
      " erfolgreich abgeschloßen!", vbInformation
  End If
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'import'" & 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 Prozedur - import"
      .Clear
    End If
  End With
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
  On Error GoTo 0
  
  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
  ' requires the function FileExists()
  Dim SQL As String
  Dim Con As String
  
  If Not FileExists(Path) Then Exit Function
  
  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


Private Function GetSheetNames(ByVal FileName As String) As Variant
  'original by Bob Phillips, adapted by j.ehrensberger
  ' requires the function FileExists()
  Dim objADO_Connection As Object, objADO_Catalog As Object, objADO_Tables As Object
  Dim lngIndex As Long, intLength As Integer, intPos As Integer, intStart As Integer
  Dim strConString As String, strTable As String
  Dim vntTmp() As Variant
  
  If Not FileExists(FileName) Then
    GetSheetNames = 0
    Exit Function
  End If
  
  If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
    strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
      "Data Source=" & FileName & ";"
  ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
    strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" _
      & "Data Source=" & FileName & ";"
  Else
    Exit Function
  End If
  
  Set objADO_Connection = CreateObject("ADODB.Connection")
  objADO_Connection.Open strConString
  Set objADO_Catalog = CreateObject("ADOX.Catalog")
  Set objADO_Catalog.ActiveConnection = objADO_Connection
  
  For Each objADO_Tables In objADO_Catalog.Tables
    strTable = objADO_Tables.Name
    intLength = Len(strTable)
    intPos = 0
    intStart = 1
    'Worksheet name with embedded spaces enclosed by single quotes
    If Left(strTable, 1) = "'" And Right(strTable, 1) = "'" Then
      intPos = 1
      intStart = 2
    End If
    'Worksheet names always end in the "$" character
    If Mid$(strTable, intLength - intPos, 1) = "$" Then
      Redim Preserve vntTmp(lngIndex)
      vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
      lngIndex = lngIndex + 1
    End If
  Next objADO_Tables
  
  If lngIndex > 0 Then GetSheetNames = vntTmp
  
  objADO_Connection.Close
  Set objADO_Catalog = Nothing
  Set objADO_Connection = Nothing
End Function


Private Function FileExists(FileName As String) As Boolean
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  FileExists = objFSO.FileExists(FileName)
  Set objFSO = Nothing
End Function


Gruß Sepp

Anzeige
AW: Excel-Datei einlesen
03.07.2015 08:22:27
Bernd
Guten Morgen Sepp,
mit den leeren Zellen hast Du natürlich recht, ich hatte nicht erwähnt, dass durchaus vorkommen kann. Auch bei anderen Zellen innerhalb einer Datenzeile.
Zur letzten Version des Makros:
Leider werden die bereits importierten Daten der ersten Datei beim Import der 2. Datei überschrieben.
Außerdem erhalte ich eine Fehlernummer 13 / Typen unverträglich beim Import der Originaldaten. Die Originaldaten enthalten nicht nur Zahlen- sondern auch Textfelder und die o. a. Leerzellen. Kann das das Problem sein?
Viele Grüße
Bernd

Datei?
03.07.2015 18:23:42
Sepp
Hallo Bernd,
lade eine der Import-Dateien hoch!
Gruß Sepp

Anzeige
AW: Datei?
06.07.2015 08:28:26
Bernd
Hallo Sepp,
die Originaldatei kann/darf ich leider nicht hochladen, aber ich zumindest folgendes vermelden. Wenn ich die Originalquelldatei öffne und unter einem anderem Name speichere, dann kommt der Fehler 13 nicht mehr.
Was weiterhin nicht funktioniert:
Beim Importieren der 2. Datei sollte diese ja der erste eingelesene Datensatz der Quelldatei 2 an den letzten Datensatz der Quelldatei 1 "angehängt" werden. Leider wird aber wohl der 1. Import überschrieben.
Ich habe eine Importdatei angehängt, die die Struktur der Originalquelldaei nachbilden soll. Im Grunde genommen können eine Zeile mehrfache Leerzellen auftreten, es gibt da leider kein System.
https://www.herber.de/bbs/user/98648.xls
Ach ja nochwas: Könnte man evtl. den Tabellenblattnamen der Quuelldatei vorgeben? Die Originaldatei hat nämlich mehrere Tabellenblätter, aber nur ein eines ist relevant für den Import!
Viele Grüße
Bernd

Anzeige
AW: Datei?
06.07.2015 10:05:40
Bernd
Da ist hochgeladen

AW: Datei?
06.07.2015 19:04:34
Sepp
Hallo Bernd,
also mit deiner Beispieltabelle und meinem Code, klappt bei mir der Import ohne Probleme.
Die Daten werden importiert und es wird auch nichts überschrieben
https://www.herber.de/bbs/user/98672.xlsm
Den Tabellennamen und den Importbereich habe ich als Konstanten am Anfang des Codes hinterlegt, ggf. einfach anpassen.
Gruß Sepp

245 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige