Sheet aus File kopieren und in zig andere einfügen
29.07.2008 16:55:53
Bastian
ich bin mal wieder absolut rat und hilflos.
Ich habe im Büro einen ganz "tollen" Auftrag bekommen.
Wir haben identisch formatierte (alle inhalte jeweils an der gleichen stelle in der file) excel files. Nun soll ich die "hübsche" Daten so zusammen tragen, dass man daraus eine Pivot-Tabelle mit den inhalten aller Files erzeugen kann.
Hierzu habe ich mir folgendes überlegt.
1. Schritt: erzeugen eines neuen Sheets in dem die benötigten werde nebeneinander bzw. untereinander eingetragen werden: (='Tabelle1'!A1).
2. Dieses Sheet in sämtliche Dateien (sind weit über 300) manuel kopieren und die Bezüge ändern
3. Macro darüber laufen lassen, dass die alle Werte aus den 300 einzelnen Dateien untereinander einfügt und nur die Werte übrig lässt.
4. Pivot tabelle erzeugen.
Zu Schritt 1: Das ist sicher Handarbeit. Das muss man halt einmal machen.
Zu Schritt2: Geht das über ein Makro? Also das neu erzeugte Tabellenblatt automatisch (mit den entsprechend angepassten bezhügen) in alle Files zu kopieren?
Zu Schritt3: Hier habe ich im Forum schon ein Makro gebastelt bekommen (hier nochmals TAUSEND DANK dafür) gefunden
option Explicit
Sub Lese_Excel_Daten()
Dim meDatei As Workbook
Dim FName$, strPfad$
Dim oData As DataObject
Dim Anzahl As Long
Const PassTabelle As String = "test" 'Passwort Tabelle
Const PassDatei As String = "test" 'Passwort Datei
strPfad = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") _
On Error GoTo goError
'Pfad angeben und Art der datei *.xls oder *.xlsm oder *.xlsx usw.
FName = Dir(strPfad & "*.xls")
EventAusAn False
ThisWorkbook.Sheets(Tabelle1.Name).Cells.ClearContents
'Schleife über alle Dateien in diesem Ordner
Set oData = New DataObject
While FName ""
If FName ThisWorkbook.Name Then
'öffne Datei
Set meDatei = Workbooks.Open(strPfad & FName, , , , PassDatei, PassDatei)
'Tabelle zuordnen
With meDatei.Sheets("datat")
meDatei.Unprotect PassTabelle
'Tabelle sichtbar machen
.Visible = True
'schutz aufheben, eventuell nicht erforderlich
.Unprotect PassTabelle
'Kopiere A2:p20
.Range("A2:P20").Copy
End With
'Einfüge Datei und Tabelle
With ThisWorkbook.Sheets(Tabelle2.Name)
'Füge ab der nächsten Freien Zelle in Spalte A ein
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End With
'Datei ohne Speichern schließen
Application.CutCopyMode = False
oData.Clear
meDatei.Close False
Anzahl = Anzahl + 1
End If
'nächste Datei im Ordner
FName = Dir()
Wend
goError:
ThisWorkbook.Activate
Sheets(Tabelle1.Name).Select
Range("A1").Select
Set oData = Nothing
EventAusAn
If Err.Number 0 Then
MsgBox "Error!" & Chr(13) & Err.Description
Else
MsgBox "" & Anzahl & " files are updated!"
End If
End Sub
Sub EventAusAn(Optional Zustand As Boolean = True)
Static ZustandAlt As Long
If Zustand = False Then ZustandAlt = Application.Calculation
With Application
.EnableEvents = Zustand
.ScreenUpdating = Zustand
.DisplayAlerts = Zustand
.Calculation = IIf(Zustand = True, ZustandAlt, xlCalculationManual)
End With
End Sub
Das sollte eigentlich gehen, oder zumindest auf meine Bedürfnisse anpassbar sein.
Zu Punkt 4. kein problem...
Aber Punkt 2 macht mir echte Sorgen.
Ist jemand von Euch in der Lage und auch noch bereit, mir ein Makro zu schreiben mit dem Punkt 2 abgedeckt ist, also ein Makro, dass es schafft von Musterdatei.xls das sheet "mustersheet" zu kopieren und in alle Files eines Ordners einzufügen und jeweils die Bezüge auf die Datei anzupassen?
Das wäre wirklich superprima!!!
Vielen Dank und viele Grüsse
Bastian