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
1436to1440
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

Dateien zusammenführen

Dateien zusammenführen
24.07.2015 14:41:50
Sven
Guten Tag zusammen,
ich verzweifle gerade an einer mir selbst gestellten Aufgabe. Bei meiner Suche nach einer Lösung habe ich bereits in mehreren Foren geforscht und die dort geposteten VBA Codes versucht an meine Aufgabenstellung anzupassen. Bin aber leider dabei gescheitert.
Ich hoffe, dass mir hier geholfen werden kann.
Problemstellung:
Ich habe einen Ordner mit 260 xlsx Dateien. Ich möchte gerne bestimmte Inhalte aus den Dateien in eine Datei zusammenfassen.Die Dateien sind immer gleich aufgebaut, heißen allerdings alle unterschiedlich.
Ich möchte nun gerne folgendes per Knopfdruck tun:
1.) Öffne die erste Datei in dem Verzeichnis
2.) Kopiere die Zellen B4; B10; B14:D14; B15:D15; B16:D16; B17:D17; B18:D18;
3.) Füge die kopierten Zellen dann folgenden Stellen in die neue Datei ein
B4 nach A4; B10 nach B4; B14:D14 nach C4:E4; B15:D15 nach F4:H4; B16:D16 nach I4:K4; B17:D17 nach L4:N4; B18:D18 nach O4:Q4;
4.) Die Vorgänge 2.) und 3.) dann bitte für jede Datei im Ordner so dass die Inhalte der Ordner hinterher alle Untereinandere in der neuen Datei stehen.
Ich hoffe Sie können mir helfen, so kann ich mir viel Arbeit ersparen.
Vielen Dank schonmal im voraus und ein schönes Wochenende!

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Dateien zusammenführen
25.07.2015 08:52:29
Sepp
Hallo Sven,
wie lautet der Name der auszulesenden Tabellen?
Gruß Sepp

AW: Dateien zusammenführen
25.07.2015 09:30:29
Sepp
Hallo Sven,
teste mal.
' **********************************************************************
' 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, vntSheets 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")
  
  strTab = "Tabelle1" 'Name der Quelltabelle(n) - Anpassen!
  
  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 <> ""
        vntSheets = GetSheetNames(strPath & strFile)
        If IsNumeric(Application.Match(strTab, vntSheets, 0)) Then
          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

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige