Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Sheet aus File kopieren und in zig andere einfügen

Betrifft: Sheet aus File kopieren und in zig andere einfügen von: Bastian Eberl
Geschrieben am: 29.07.2008 16:55:53

Guten Abend,

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

  

Betrifft: AW: Daten aus vielen Mappen sammeln von: Erich G.
Geschrieben am: 29.07.2008 19:39:17

Hallo Bastian,
dieses Vorgehen - insbesondere Schritt 2 - scheint mir "suboptimal" zu sein.

Was du brauchst, ist doch nur eine "Sammel"-Mappe, in der alle auszuwertenden Daten zusammengeführt werden.
Dazu musst du doch nicht 300 Dateien ändern.

Ich würde das so vorschlagen:
Neue "Sammel"-Mappe anlegen, mit einem Blatt
In einer Schleife alle relevanten Daten aus den 300 Dateien in das Blatt übertragen
Pivot erstellen.

Für das Übertragen sind vielleicht ein paar mehr Codezeilen nötig.
Das sollte aber weniger Aufwand machen als die Änderung der 300 Mappen.

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort


  

Betrifft: AW: Sheet aus File kopieren und in zig andere einfügen von: Daniel
Geschrieben am: 29.07.2008 20:00:16

Hi

prinzipiell ist es so, daß das Lesen von Daten aus geschlossenen Dateien recht langsam ist.
wenn die Dateien nicht allzugross sind, dann ist es oft besser, die Dateien nacheinander zu öffen und die benötigten Daten in die Masterdatei zu kopieren.
das hat den Vorteil daß du die einzelnen Dateien nicht verändern musst

das folgende Makro z.B. sucht sich aus allen Excelfiles des angegeben Verzeichnisses die Zelle A1 des ersten Sheets:


Pfad = ThisWorkbook.Path
ThisWorkbook.Sheets(1).Cells.ClearContents
Datei = Dir(Pfad & "\*.xls")
Application.ScreenUpdating = False
Do Until Datei = ""
If Datei <> ThisWorkbook.Name Then
Workbooks.Open Pfad & "\" & Datei, ReadOnly:=True, UpdateLinks:=0
With ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).Value = Datei
.Offset(1, 1).Value = ActiveWorkbook.Sheets(1).Cells(1, 1).Value
End With
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
End If
Datei = Dir()
Loop
Application.ScreenUpdating = True
End Sub

Gruß, Daniel


  

Betrifft: AW: Sheet aus File kopieren und in zig andere einfügen von: Daniel
Geschrieben am: 29.07.2008 20:01:15

Hi

prinzipiell ist es so, daß das Lesen von Daten aus geschlossenen Dateien recht langsam ist.
wenn die Dateien nicht allzugross sind, dann ist es oft besser, die Dateien nacheinander zu öffen und die benötigten Daten in die Masterdatei zu kopieren.
das hat den Vorteil daß du die einzelnen Dateien nicht verändern musst

das folgende Makro z.B. sucht sich aus allen Excelfiles des angegeben Verzeichnisses die Zelle A1 des ersten Sheets:

Sub einlesen()
Dim Pfad As String
Dim Datei As String


Pfad = ThisWorkbook.Path
ThisWorkbook.Sheets(1).Cells.ClearContents
Datei = Dir(Pfad & "\*.xls")
Application.ScreenUpdating = False
Do Until Datei = ""
    If Datei <> ThisWorkbook.Name Then
        Workbooks.Open Pfad & "\" & Datei, ReadOnly:=True, UpdateLinks:=0
        With ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
            .Offset(1, 0).Value = Datei
            .Offset(1, 1).Value = ActiveWorkbook.Sheets(1).Cells(1, 1).Value
        End With
        ActiveWorkbook.Saved = True
        ActiveWorkbook.Close
    End If
    Datei = Dir()
Loop
Application.ScreenUpdating = True
End Sub




Gruß, Daniel


  

Betrifft: AW: Sheet aus File kopieren und in zig andere einfügen von: Bastian Eberl
Geschrieben am: 30.07.2008 10:49:16

Hallo ihr zwei,

vielen dank für die schnelle hilfe.
das projekt hat sich zum glück erledigt.
dennoch tausend dank für eure hlfe.

viele grüsse
bastian


 

Beiträge aus den Excel-Beispielen zum Thema "Sheet aus File kopieren und in zig andere einfügen"