Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1428to1432
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
Inhaltsverzeichnis

Erste Spalte aus allen Dateien eines Ordners zusam

Erste Spalte aus allen Dateien eines Ordners zusam
16.06.2015 14:00:22
wizard
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

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Erste Spalte aus allen Dateien eines Ordners zusam
16.06.2015 18:21:37
wizard
Weis jemand weiter? Ich habe verschiedene Varianten probiert aber es will nicht ;)

AW: Erste Spalte aus allen Dateien eines Ordners zusam
16.06.2015 18:29:51
Sepp
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

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

Anzeige
AW: Erste Spalte aus allen Dateien eines Ordners zusam
16.06.2015 19:24:25
Sepp
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

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

AW: Erste Spalte aus allen Dateien eines Ordners zusam
16.06.2015 20:17:16
wizard
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?

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

vielleicht hilft es, ...
16.06.2015 21:04:26
Sepp
... 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

Anzeige

310 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige