Mehrere Dateien in eine Datei einfügen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Michael!
Ungetestet, sollte aber laufen!
Kopiere den Code in ein allgemeines Modul deiner Masterdatei.
Den Pfad zu deinen dateien anpassen!

Sub Daten_Auslesen()
'by J.Ehrensberger

Dim fSearch As FileSearch
Dim wkb As Workbook, wks As Worksheet, wsData As Worksheet
Dim strPath As String
Dim iCnt As Integer, lRow As Long
On Error GoTo ERRORHANDLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
Set wsData = Sheets("Tabelle1")  'Tabelle zum Eintragen der Daten

strPath = "D:\Temp"  'Pfad des Ordners mit den Dateien - anpassen

Set fSearch = Application.FileSearch
With fSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeExcelWorkbooks
.Execute
   For iCnt = 1 To .FoundFiles.Count

   Set wkb = Workbooks.Open(.FoundFiles(iCnt))

      For Each wks In wkb.Worksheets
         If wks.Visible <> xlSheetVisible Then
         lRow = lRow + 1
         wsData.Rows(lRow).Value = wks.Rows("3").Value
         Exit For
         End If
      Next

   wkb.Close False

   Set wkb = Nothing

   Next
End With
Set fSearch = Nothing
ERRORHANDLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
If lRow > 0 Then MsgBox "Es wurden " & lRow & " Datensätze importiert!" & _
                                                   Space(15), vbInformation
End Sub

Hallo Michael!
Warum du nur Nullen eingetragen bekommst, kann ich mir nicht erklären!
Hab den Code getestet, und er funktioniert ausgezeichnet.
Hier eine Versionsbezogene ermittlung der Daten.
Ich gehe davon aus, das vor der Versionsbezeichnung immer ein "_" steht!

Option Explicit
'Variablen auf Modulebene---------------------------------------
Dim fSearch As FileSearch
Dim wkb As Workbook, wks As Worksheet, wsData As Worksheet
Dim lRow As Long
'---------------------------------------------------------------

Sub Daten_Auslesen()
Dim tmp As String, strPath As String
Dim iCnt As Integer, n As Integer
Dim arrFile() As Variant
Dim fso
'by J.Ehrensberger
'
'Auslesen von Dateien eines Verzeichnisses
'Wenn von einer Datei mehrere Versionen vorhanden sind,
'nur die neueste Version auslesen

'Erkennungszeichen ist ein "_" vor der Versionsbezeichnung

On Error GoTo ERRORHANDLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
lRow = 0
Set fso = CreateObject("Scripting.FileSystemObject")
Set wsData = Sheets("Tabelle1")  'Tabelle zum Eintragen der Daten

strPath = "D:\Temp"  'Pfad des Ordners mit den Dateien - anpassen

Set fSearch = Application.FileSearch
With fSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False  '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeExcelWorkbooks
.Execute sortorder:=msoSortOrderDescending
ReDim arrFile(.FoundFiles.Count - 1)
   'Einlesen der Dateinamen in Array
   For iCnt = 1 To .FoundFiles.Count
   arrFile(iCnt - 1) = fso.getbasename(.FoundFiles(iCnt))
   Next

   'Schleife(1) start. Elemente des Arrays durchlaufen
   For n = 0 To UBound(arrFile)
      'Wenn "_" im Dateinamen, dann
      If InStr(1, arrFile(n), "_") > 0 Then
      'Funktion zum auslesen der Datei aufrufen
      getData (.FoundFiles(n + 1))
      'Dateiname bis zum "_" ermitteln
      tmp = Left(arrFile(n), InStr(1, arrFile(n), "_") - 1)
         'Schleife(2) start
         Do
            'Wenn die nächste Datei den selben namen hat, dann
            If Left(arrFile(n + 1), Len(tmp)) = tmp Then
            'Zähler Schleife(1) inkrementieren
            n = n + 1
               If n > UBound(arrFile) Then Exit For
            'Wenn name nicht gleich, dann
            Else
               'Schleife(2) verlassen
               Exit Do
            End If
         'Wendepunkt Schleife(2)
         Loop
      'Wenn "_" nicht im Dateinamen gefunden, dann
      Else
      'Funktion zum auslesen der Datei aufrufen
      getData (.FoundFiles(n + 1))
      End If
   'Wendepunkt Schleife(1)
   Next
End With
ERRORHANDLER:
Set fSearch = Nothing
Set fso = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
If lRow > 0 Then MsgBox "Es wurden " & lRow & " Datensätze importiert!" & _
                                                   Space(15), vbInformation
End Sub
Function getData(strFile As String)
'Auslesen der Daten aus Datei

   'Datei öffnen
   Set wkb = Workbooks.Open(strFile)
      'Alle Tabellen durchlaufen
      For Each wks In wkb.Worksheets
         'Wenn Tabelle ausgeblendet, dann
         If wks.Visible <> xlSheetVisible Then
         'Zeilenzähler für "Tabelle1" inkrementieren
         lRow = lRow + 1
         'Zeile 3 aus Tabelle in "Tabelle1" schreiben
         wsData.Rows(lRow).Value = wks.Rows("3").Value
         'Schleife verlassen
         Exit For
         End If
      Next
   'Datei schliessen
   wkb.Close False
   Set wkb = Nothing

End Function

Beliebteste Forumthreads (12 Monate)

Mehrere Dateien in eine Datei einfügen

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mehrere Dateien in eine Datei einfügen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread