Erste Spalte aus allen Dateien eines Ordners zusam

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

Betrifft: Erste Spalte aus allen Dateien eines Ordners zusam
von: wizard
Geschrieben am: 16.06.2015 14:00:22

Hallo,
kann mir jemand weiterhelfen, wie ich die erste Spalte einer jeden Excel-Datei in einem bestimmten Ordner nebeneinander in eine neue Excel-Datei automatisiert per VBA schreiben kann?
Von mehreren Tabellenblättern in eins bekomme ich hin. Von mehreren Dateien in ein Tabellenblatt allerdings nicht...
Lg

Bild

Betrifft: AW: Erste Spalte aus allen Dateien eines Ordners zusam
von: wizard
Geschrieben am: 16.06.2015 18:21:37
Weis jemand weiter? Ich habe verschiedene Varianten probiert aber es will nicht ;)

Bild

Betrifft: AW: Erste Spalte aus allen Dateien eines Ordners zusam
von: Sepp
Geschrieben am: 16.06.2015 18:29:51
Hallo Christopher,
schon wieder ich ;-)
Aus welchem Tabellenblatt der Datei, oder mehrere pro Datei?
Sollen die einzelnen Spalten der jeweiligen Datei zugeordnet werden? Z. B. als Überschrift der Dateiname.

Gruß Sepp


Bild

Betrifft: AW: Erste Spalte aus allen Dateien eines Ordners zusam
von: wizard
Geschrieben am: 16.06.2015 18:50:44
Ist nur ein Tabellenblatt ;) Überschriften sind alle in der Spalte reicht also völlig nur die erste Spalte einer jeden Datei zusammenzufügen

Bild

Betrifft: AW: Erste Spalte aus allen Dateien eines Ordners zusam
von: Sepp
Geschrieben am: 16.06.2015 19:24:25
Hallo,

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

Option Explicit

Sub collectData()
  Dim strFile As String, strPath As String
  Dim lngCalc As Long, lngI As Long
  Dim objADO As Object, vntSheets As Variant
  Dim objSH As Worksheet
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = -4135
    .DisplayAlerts = False
  End With
  
  strPath = fncBrowseForFolder
  
  If strPath <> "" Then
    Set objSH = ThisWorkbook.Sheets.Add 'oder Tabellennamen angeben = ThisWorkbook.Sheets("Tabelle1")
    strPath = strPath & "\"
    strFile = Dir(strPath & "*.xls*", vbNormal)
    Do While strFile <> ""
      lngI = lngI + 1
      vntSheets = GetSheetNames(strPath & strFile)
      Set objADO = ExcelTable(strPath & strFile, CStr(vntSheets(0)), "A1:A20000")
      objSH.Cells(1, lngI).CopyFromRecordset objADO
      objADO.Close
      strFile = Dir
    Loop
  End If
  
  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 = lngCalc
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
End Sub


Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
  Dim objFlderItem As Object, objShell As Object, objFlder As Object
  
  Set objShell = CreateObject("Shell.Application")
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
  
  If objFlder Is Nothing Then GoTo ErrExit
  
  Set objFlderItem = objFlder.Self
  fncBrowseForFolder = objFlderItem.Path
  
  ErrExit:
  
  Set objShell = Nothing
  Set objFlder = Nothing
  Set objFlderItem = Nothing
End Function


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


Bild

Betrifft: AW: Erste Spalte aus allen Dateien eines Ordners zusam
von: wizard
Geschrieben am: 16.06.2015 20:11:23
Wow meric auch dafür =)

Bild

Betrifft: AW: Erste Spalte aus allen Dateien eines Ordners zusam
von: wizard
Geschrieben am: 16.06.2015 20:17:16
Eine Sache ist mir noch aufgefallen. Es erscheinen Renditen wie 5,7948619151e-005 die sich nicht mehr in eine Nachkommazahl transferieren lassen. Hängt das am Code?

Bild

Betrifft: AW: Erste Spalte aus allen Dateien eines Ordners zusam
von: Sepp
Geschrieben am: 16.06.2015 20:35:36
Hallo Christopher,
das hängt nicht von Code, sondern von den importierten Daten ab

Gruß Sepp


Bild

Betrifft: vielleicht hilft es, ...
von: Sepp
Geschrieben am: 16.06.2015 21:04:26
... wenn wir die Zellen vorher als Zahl formatieren.

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

Option Explicit

Sub collectData()
  Dim strFile As String, strPath As String
  Dim lngCalc As Long, lngI As Long
  Dim objADO As Object, vntSheets As Variant
  Dim objSH As Worksheet
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = -4135
    .DisplayAlerts = False
  End With
  
  strPath = fncBrowseForFolder
  
  If strPath <> "" Then
    Set objSH = ThisWorkbook.Sheets.Add 'oder Tabellennamen angeben = ThisWorkbook.Sheets("Tabelle1")
    objSH.Cells.NumberFormat = "#0.0000000000"
    strPath = strPath & "\"
    strFile = Dir(strPath & "*.xls*", vbNormal)
    Do While strFile <> ""
      lngI = lngI + 1
      vntSheets = GetSheetNames(strPath & strFile)
      Set objADO = ExcelTable(strPath & strFile, CStr(vntSheets(0)), "A1:A20000")
      objSH.Cells(1, lngI).CopyFromRecordset objADO
      objADO.Close
      strFile = Dir
    Loop
    objSH.Columns.AutoFit
  End If
  
  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 = lngCalc
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
End Sub


Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
  Dim objFlderItem As Object, objShell As Object, objFlder As Object
  
  Set objShell = CreateObject("Shell.Application")
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
  
  If objFlder Is Nothing Then GoTo ErrExit
  
  Set objFlderItem = objFlder.Self
  fncBrowseForFolder = objFlderItem.Path
  
  ErrExit:
  
  Set objShell = Nothing
  Set objFlder = Nothing
  Set objFlderItem = Nothing
End Function


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


sonst lade mal eine Tabelle mit der Spalte hoch deren Zahlen beim Import nicht korrekt dargestellt werden.
Gruß Sepp


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Erste Spalte aus allen Dateien eines Ordners zusam"