Mehrere Exceldateien in einer Datei zusammenfassen
19.02.2013 15:03:28
Chris
ich habe folgendes Problem:
ch bin total Ratlos, habe ein paar ansätze, aber nichts konkretes bin in Makro Programmierung nicht wirklich gut.
Folgendes Szenario:
Ich habe mehrere Exceldateien mit gleicher Struktur in einem Verzeichnis liegen. Alle diese Dateien möchte ich in einer neuen Datei zusammenfassen bzw. nur ein Tabellenblatt soll ausgewählt werden.
Das funktioniert auch soweit, aber wenn ich jetzt Filter einbauen möchte geht das nicht.
In den Quelldateien steht in Spalte E die Information die ich in der Zieldatei bereits in die Zelle A6 eingegeben hat, er soll mir also nur die Werte übernehmen, wo diese beiden Werte übereinstimmen.
Kann mir jemand helfen?
Folgende Ansätze habe ich mal probiert, funktioniert aber noch nicht wirklich.
Sub Syncro()
Dim i As Long
Dim Pnr As Long
Dim Zeile As Long
Dim LetzteZeile As Long
Dim Pnr1 As Long
Dim Pnr2 As Long
Dim Suchbegriff1 As String
Dim Info As Variant
Dim Firma As Variant
Dim Source As String
' Firmenbegriff auswählen und Projektnummern abfragen
Suchbegriff1 = Range("A6").Value
Pnr1 = Application.InputBox(Prompt:="Bitte geben Sie die erste Projektnummer ein", _
Title:="Ältestes Projekt", Type:=1)
Pnr2 = Application.InputBox(Prompt:="Bitte geben Sie die letzte Projektnummer ein", _
Title:="Jüngstes Projekt", Type:=1)
' Ausschalten Bildschirmverfolgung
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Aufrufen Datei aus Verzeichniss (Schleife!)
For Pnr = Pnr1 To Pnr2
Source = "N:\Test\Dateien\"
Workbooks.Open Filename:=Source & Pnr & ".xlsx"
For Zeile = 12 To 191
Workbooks.Open Filename:=Source & Pnr & ".xlsx"
Sheets("BZP").Select
If Cells(Zeile, 6).Value = Suchbegriff1 Then
Firma = Suchbegriff1
Range(Firma.Address).Select
lngR = ActiveCell.Row
Info = Range("A,lngR:ElngR").Select
Selection.Copy
End If
Zeile = Zeile + 1
'Infos kopieren
Windows("Gesamt.xlsm").Activate
LetzteZeile = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Range("C:C", LetzteZeile).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Bauvorhaben kopieren
Workbooks.Open Filename:=Source & Pnr & ".xlsx"
Sheets("BZP").Select
Range("A6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Gesamt.xlsm").Activate
Range("A:A", LetzteZeile).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
Pnr = Pnr + 1
Next
End Sub
Er bringt mir an dieser Stelle:
Range("C:C", LetzteZeile).Select
Die Methode Range ist fehlgeschlagen 1004.
Wer kann helfen, oder habt ihr einen ganz anderen Ansatz.
Danke!