Dateien zusammenführen von Sven vom 24.07.2015 14

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

Betrifft: Dateien zusammenführen von Sven vom 24.07.2015 14
von: Sven
Geschrieben am: 04.08.2015 10:49:26

Guten Morgen zusammen,
ich beziehe mich auf meine Anfrage vom 24.07.2015.
Leider war ich im Urlaub und kann nun nicht mehr auf die hilfreiche Antwort von SEPP Antworten. Oder ich bin zu blöd den Antwort Button zu finden.
Danke also für die Antwort, leider bricht das Programm mit folgendem Hinweis ab:
Fehler in Prodzedur: "Collect Data"
Beschreibung: Die externe Tabelle hat nicht das erwartet Format
Noch ein Hinweis, die einzulesenden Tabellen habe alle einen anderen Namen, sind aber vom Aufbau gleich.

Bild

Betrifft: AW: Dateien zusammenführen von Sven vom 24.07.2015 14
von: Sepp
Geschrieben am: 04.08.2015 11:45:07
Hallo Sven,
auf archivierte Beiträge kann nicht geantwortet werden, ist leider in diesem Forum so.
Lade doch eine Beispielmappe hoch, sie sollte vom Aufbau her den Originalen gleichen.
Wenn die Tabellen immer anders heißen, wie soll der Name der zu importierenden Tabelle ermittelt werden, oder haben die Mappen jeweils nur eine Tabelle, dann ist es kein Problem.

Gruß Sepp


Bild

Betrifft: AW: Dateien zusammenführen von Sven vom 24.07.2015 14
von: Sven
Geschrieben am: 04.08.2015 12:11:47
Hallo Sepp,
danke für deine Antwort. Da bin ich dann beruhigt, dass ich nicht zu blöd war den Antwortknopf zu finden.
Die Datei aus der ich importieren will habe ich hochgeladen:
https://www.herber.de/bbs/user/99316.xlsx
Das Format ist immer gleich, aber die Tabellennamen sind alle anders.

Bild

Betrifft: AW: Dateien zusammenführen von Sven vom 24.07.2015 14
von: Sepp
Geschrieben am: 04.08.2015 12:20:53
Hallo Sven,
importiert wird immer aus der ersten Tabelle der Import-Datei in die Tabelle1 der Datei die den Code enthält.
Makro starten > Order auswählen > "Import Starten"

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

Option Explicit

Sub collectData()
Dim strPath As String, strFile As String, strRef As String, strTab As String
Dim vntRef As Variant
Dim lngI As Long, lngNext As Long

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
  .DisplayAlerts = False
End With

vntRef = Array("B4", "B10", "B14", "C14", "D14", "B15", "C15", "D15", "B16", "C16", "D16", "B17", _
  "C17", "D17", "B18", "C18", "D18")

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\Forum" 'Startverzeichnis
  .Title = "Datenimport Ordnerauswahl"
  .ButtonName = "Import Starten"
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

With ThisWorkbook.Sheets("Tabelle1")
  lngNext = Application.Max(4, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
  If Len(strPath) Then
    strFile = Dir(strPath & "*.xls*", vbNormal)
    Do While strFile <> ""
      If strFile <> ThisWorkbook.Name Then
        strTab = GetSheetNames(strPath & strFile)(0)
        DoEvents
        Application.StatusBar = "Imort aus Datei: " & strFile & " Bitte warten..."
        DoEvents
        strRef = "='" & strPath & "[" & strFile & "]" & strTab & "'!"
        For lngI = 1 To UBound(vntRef) + 1
          .Cells(lngNext, lngI).Formula = strRef & vntRef(lngI - 1)
        Next
        lngNext = lngNext + 1
        strFile = Dir
      End If
    Loop
  End If
  .Calculate
  .Range(.Cells(4, 1), .Cells(lngNext, UBound(vntRef) + 1)) = .Range(.Cells(4, 1), .Cells(lngNext, _
    UBound(vntRef) + 1)).Value
End With

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'collectData'" & 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 - collectData"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
  .DisplayAlerts = True
  .StatusBar = False
End With

End Sub



Private Function GetSheetNames(ByVal FileName As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
Dim objADO As Object, objCAT As Object, objTAB As Object
Dim lngI As Long, intL As Integer, intP As Integer, intS As Integer
Dim strCon As String, strTab As String
Dim vntTmp() As Variant

If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
  strCon = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
    "Data Source=" & FileName & ";"
ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
  strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" _
    & "Data Source=" & FileName & ";"
Else
  Exit Function
End If

Set objADO = CreateObject("ADODB.Connection")
objADO.Open strCon
Set objCAT = CreateObject("ADOX.Catalog")
Set objCAT.ActiveConnection = objADO

For Each objTAB In objCAT.Tables
  strTab = objTAB.Name
  intL = Len(strTab)
  intP = 0
  intS = 1
  'Worksheet name with embedded spaces enclosed by single quotes
  If Left(strTab, 1) = "'" And Right(strTab, 1) = "'" Then
    intP = 1
    intS = 2
  End If
  'Worksheet names always end in the "$" character
  If Mid$(strTab, intL - intP, 1) = "$" Then
    Redim Preserve vntTmp(lngI)
    vntTmp(lngI) = Mid$(strTab, intS, intL - (intS + intP))
    lngI = lngI + 1
  End If
Next objTAB

If lngI > 0 Then GetSheetNames = vntTmp

objADO.Close
Set objCAT = Nothing
Set objADO = Nothing
End Function


Gruß Sepp


Bild

Betrifft: Korrektur!
von: Sepp
Geschrieben am: 04.08.2015 12:25:23
Hallo nochmal,
nimm diesen Code!

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

Option Explicit

Sub collectData()
Dim strPath As String, strFile As String, strRef As String, strTab As String
Dim vntRef As Variant
Dim lngI As Long, lngNext As Long

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
  .DisplayAlerts = False
  .EnableCancelKey = xlInterrupt
End With

vntRef = Array("B4", "B10", "B14", "C14", "D14", "B15", "C15", "D15", "B16", "C16", "D16", "B17", _
  "C17", "D17", "B18", "C18", "D18")

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\Forum" 'Startverzeichnis
  .Title = "Datenimport Ordnerauswahl"
  .ButtonName = "Import Starten"
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

With ThisWorkbook.Sheets("Tabelle1")
  lngNext = Application.Max(4, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
  If Len(strPath) Then
    strFile = Dir(strPath & "*.xls*", vbNormal)
    Do While strFile <> ""
      If strFile <> ThisWorkbook.Name Then
        strTab = GetSheetNames(strPath & strFile)(0)
        DoEvents
        Application.StatusBar = "Imort aus Datei: " & strFile & " Bitte warten..."
        DoEvents
        strRef = "='" & strPath & "[" & strFile & "]" & strTab & "'!"
        For lngI = 1 To UBound(vntRef) + 1
          .Cells(lngNext, lngI).Formula = strRef & vntRef(lngI - 1)
        Next
        lngNext = lngNext + 1
      End If
      strFile = Dir
    Loop
  End If
  .Calculate
  .Range(.Cells(4, 1), .Cells(lngNext, UBound(vntRef) + 1)) = .Range(.Cells(4, 1), .Cells(lngNext, _
    UBound(vntRef) + 1)).Value
End With

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'collectData'" & 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 - collectData"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
  .DisplayAlerts = True
  .StatusBar = False
End With

End Sub



Private Function GetSheetNames(ByVal FileName As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
Dim objADO As Object, objCAT As Object, objTAB As Object
Dim lngI As Long, intL As Integer, intP As Integer, intS As Integer
Dim strCon As String, strTab As String
Dim vntTmp() As Variant

If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
  strCon = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
    "Data Source=" & FileName & ";"
ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
  strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" _
    & "Data Source=" & FileName & ";"
Else
  Exit Function
End If

Set objADO = CreateObject("ADODB.Connection")
objADO.Open strCon
Set objCAT = CreateObject("ADOX.Catalog")
Set objCAT.ActiveConnection = objADO

For Each objTAB In objCAT.Tables
  strTab = objTAB.Name
  intL = Len(strTab)
  intP = 0
  intS = 1
  'Worksheet name with embedded spaces enclosed by single quotes
  If Left(strTab, 1) = "'" And Right(strTab, 1) = "'" Then
    intP = 1
    intS = 2
  End If
  'Worksheet names always end in the "$" character
  If Mid$(strTab, intL - intP, 1) = "$" Then
    Redim Preserve vntTmp(lngI)
    vntTmp(lngI) = Mid$(strTab, intS, intL - (intS + intP))
    lngI = lngI + 1
  End If
Next objTAB

If lngI > 0 Then GetSheetNames = vntTmp

objADO.Close
Set objCAT = Nothing
Set objADO = Nothing
End Function


Gruß Sepp


Bild

Betrifft: AW: Korrektur!
von: Sven
Geschrieben am: 04.08.2015 12:35:23
Hallo Sepp,
ich werd bekloppt. Es hat funktioniert. Ist ja der Wahnsinn!
Vielen Dank!!!!
Beste Grüße
Sven

 Bild

Beiträge aus den Excel-Beispielen zum Thema " Dateien zusammenführen von Sven vom 24.07.2015 14"