Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
852to856
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
852to856
852to856
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

600 Excel Mappen Zu Einer Machen

600 Excel Mappen Zu Einer Machen
16.03.2007 09:32:00
Kai
Hallo zusammen,
wir haben hier 600 Excel Mappen mit je einer Excel Tabelle. Gibt es einen schnellen weg sie zu einer Mappe zu machen?
Der Grund: In jeder dieser 600 Tabellen gibt es nur eine Zeile, die ich brauche. Ich müsste also jede Tabelle einmal öffnen un dann nach dieser Zeile filtern und sie rauskopieren. Dies möchte ich schneller machen. Also dachte ich mir alle Tabellen zu einer machen und dann erst filtern.
Jemand eine Idee?

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: 600 Excel Mappen Zu Einer Machen
16.03.2007 09:45:00
Holger
ist das immer die gleiche Zeile, heißt das Tabellenblatt immer gleich, liegen die in einem Ordner, liegen da noch andere dateien, ...?
Holger
AW: 600 Excel Mappen Zu Einer Machen
16.03.2007 09:58:00
Kai
Hallo Holger,
alle Mappen sind in einem Verzeichnis. Die Tabelle heisst immer Tabelle1 und ist auch immer gleich aufgebaut.
AW: 600 Excel Mappen Zu Einer Machen
16.03.2007 10:00:39
Holger
und um welche Zeile geht es: immer zeile xxx
wo soll die dann eingetragen werden?
Holger
AW: 600 Excel Mappen Zu Einer Machen
16.03.2007 10:08:00
Kai
Es geht um alle Zeilen. Von 1 bis x. In einer Tabelle habe ich z.B. Zeile 1-80, in einer anderen 1-150. Die sollen dann zu einer Mappe zusammengeführt werden und ich erhalte Zeile 1-230. Also einfach darunter hängen.
Anzeige
AW: 600 Excel Mappen Zu Einer Machen
16.03.2007 10:40:00
Kai
Hallo Holger,
ich habe das hier gerade bei Herber gefunden. Es klappt aber noch nicht ganz. Und zwar wird nur der Inhalt von einer Arbeitsmappe übernommen (ich denke die erste aus dem Verzeichnis \Bla). Dann ist Schluss. Vielleicht hast du eine Idee?

Sub Zusammenfassen()
Dim wbkQ As Workbook, arr As Variant, iNr As Integer
Dim datUhr As Date, iRowQ As Long, iRowZ As Long, iCol As Integer
Const strVerz = "c:\bla"       ' Ordner/Verzeichnis mit den Quellmappen
Const boolInf = False             ' False, wenn Dateiname+Datum nicht in die Liste sollen
Const vBlatt = "Tabelle1" ' "Tabelle1"    ' Blattnummer oder Blattname in den Quellmappen
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
arr = FileArray(strVerz, "*.xls")
For iNr = 1 To UBound(arr)
If arr(iNr)  ThisWorkbook.Name Then
datUhr = Now
Set wbkQ = Workbooks.Open(strVerz & "\" & arr(iNr), 0)
With wbkQ.Worksheets(vBlatt)
iRowQ = .Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Activate
If iNr = 1 Then
If IsEmpty(Cells(1, 1)) Then
.Rows(1).Copy
Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Cells(1, 1).Select
ActiveWindow.FreezePanes = True
End If
If boolInf Then
iCol = Cells(1, Columns.Count).End(xlToLeft).Column
If Cells(1, iCol - 1) & Cells(1, iCol) = "Quelldateiam" Then
iCol = iCol - 1
Else
iCol = iCol + 1
Range(Cells(1, iCol), Cells(1, iCol + 1)) = Split("Quelldatei am")
End If
End If
End If
If iRowQ > 1 Then
iRowZ = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range(.Rows(2), .Rows(iRowQ)).Copy
Cells(iRowZ, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Application.CutCopyMode = False
If boolInf Then
Range(Cells(iRowZ, iCol), Cells(iRowZ + iRowQ - 2, iCol)) = wbkQ.Name
Range(Cells(iRowZ, iCol + 1), Cells(iRowZ + iRowQ - 2, iCol + 1)) = datUhr
End If
End If
End With
wbkQ.Close savechanges:=False
End If
Next iNr
If UBound(arr) > -1 Then
Rows(1).HorizontalAlignment = xlHAlignCenter
If boolInf Then Columns(iCol + 1).NumberFormat = "dd.mm.yyyy hh:mm:ss"
ActiveSheet.UsedRange.Columns.AutoFit
iRowZ = iRowZ + iRowQ - 1
Application.Goto Cells(IIf(iRowZ > 25, iRowZ - 25, 1), 1), True
Cells(iRowZ, 1).Select
End If
ERRORHANDLER:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub


Function FileArray(ByVal strPath As String, sPattern As String)
Dim arr(), iNr As Integer, tmp As String
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.Filename = sPattern
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
ReDim arr(1 To .FoundFiles.Count)
For iNr = 1 To .FoundFiles.Count
tmp = .FoundFiles(iNr)
arr(iNr) = Right(tmp, Len(tmp) - InStrRev(tmp, "\"))
Next iNr
Else
ReDim arr(-1 To -1)
MsgBox "Es wurden keine Dateien gefunden.", vbInformation
End If
End With
FileArray = arr
End Function

Anzeige
AW: 600 Excel Mappen Zu Einer Machen
16.03.2007 11:05:35
Holger
Hallo Kai,
ich habe auch ein wenig gebastelt. leider kann ich das nicht vollenden, weil ich nicht genau die Ursprungszeilen/Zielzeilen/... weiß.
Option Explicit

Sub DateienSuchen()
'Es wird nach Dateien mit der Endung .xls gesucht
'Gefundene Dateinamen werden untereinander in das
'erste Blatt geschrieben
Dim strPath As String
Dim wkb As Workbook
Dim IndFile As Integer
Dim intZeil As Integer
Dim txtDatei As Variant
Dim datName As String
Set wkb = ActiveWorkbook
strPath = "H:\test" 'hier Verzeichnisname ohne abschl. \
With Application.FileSearch
.LookIn = strPath
'.SearchSubFolders = True   '(falls Unterverzeichnisse)
.Filename = "*.xls"
If .Execute > 0 Then
intZeil = 1
For IndFile = 1 To .FoundFiles.Count
datName = Right(.FoundFiles(IndFile), Len(.FoundFiles(IndFile)) - Len(strPath) - 1)
If datName  ThisWorkbook.Name Then
Workbooks.Open (.FoundFiles(IndFile))
'hier kopieren z.B.
Range("A2").Select
Selection.Copy
'hier einfügen z.B.
Workbooks(wkb.Name).Activate
Cells(intZeil, 1).Select
ActiveSheet.Paste
'hier schließen
Workbooks(datName).Close
intZeil = intZeil + 1
End If
Next IndFile
End If
End With
Set wkb = Nothing
End Sub
Holger
Anzeige
AW: 600 Excel Mappen Zu Einer Machen
16.03.2007 12:09:00
Kai
Hallo Holger,
eine Mischung aus beiden klappt :-) Super, das spart uns eine ganze Menge Arbeit. Ich danke dir.

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige