Daten kopieren aus mehreren Dateien

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Daten kopieren aus mehreren Dateien
von: Torsten K.
Geschrieben am: 06.11.2003 12:30:39

Hallo beisammen,

ich hatte diese Frage Mitte Oktober schon mal ins Forum gestellt und ein Antwort von xXx erhalten. Aber nunmehr haben sich die Voraussetzungen so verändert, daß ich die entsprechenden Anpassungen als VBA-Neuling nicht alleine hinbekomme. Daher nochmals eine Anfrage:

In einem Folder habe ich verschiedene Dateien ("OEM_1" bis "OEM_14", "SV_9*"), deren Inhalte ich jeweils aus einem bestimmten Worksheet ("Upload") in eine Datei ("COPA_IMSO"), Worksheet ("Daten") zusammenführen möchte. Das würde ich vielleicht noch alleine hinkriegen. Mein Problem dabei ist:
- Die Worksheets ("Upload") der verschiedenen Dateien sind unterschiedlich lang, daß heißt, beim Kopieren muß geprüft werden, wie groß der Range ist, z.B. (A4:DDxxxx), wobei der Beginn immer bei A4 und das Ende in Spalte DD liegt.
- Beim Einfügen in die Datei ("COPA_IMSO") muß vorher geprüft werden, welche nächste Zelle in Spalte A frei ist, um die Daten dann dort einzufügen.

Wenn Ihr mir helfen könnt, würde eine ganze Menge manueller Kopiervorgänge überflüssig werden.
Für Eure Unterstützung im voraus besten Dank.

Gruß
Torsten

Bild


Betrifft: AW: Daten kopieren aus mehreren Dateien
von: Dan
Geschrieben am: 06.11.2003 13:28:16

' Hallo Torsten,

' wie gross der Bereich ist, z.B so ermitteln :

Public

Sub BereichErmiteln()
    Dim rBereich As Range
    
    ' in dem Bereich durfen keine leere Spalten oder leere Zeilen vorhanden sein
    Set rBereich = Application.ActiveSheet.Range("a4").CurrentRegion
    rBereich.Activate
    
End Sub


' ----------------------------------------------------------------------------------
' Die letzte Zeile z.B. mit dieser simplen Funktion ermitteln :

Option Explicit


Public

Function GetLastFreeCellRow(ByVal Wsh As Worksheet, _
                                Optional ByVal StartCol As Integer = 1, _
                                Optional ByVal StartRow As Long = 1) As Long
    On Error GoTo ErrH
    
    With Wsh
        Do While (.Cells(StartRow, StartCol).Value <> "")
            StartRow = StartRow + 1
        Loop
    End With
            
    GetLastFreeCellRow = StartRow
    Exit Function
ErrH:
    MsgBox "

Function LastFreeCellRow() : " & vbCrLf & "Laufzeitsfehler Nr. " & Err.Number & ". " & Err.Description
    GetLastFreeCellRow = 0
End Function


Public

Sub Test_GetLastFreeCellRow()
    Dim LastFreeCellRow&
    
    ' die Suche beginnt in der Spalte StartCol und in der Zeile StarRow, und im Sheet Wsh
    LastFreeCellRow& = GetLastFreeCellRow(Wsh:=ActiveSheet, StartCol:=6, StartRow:=15)
    
    If (LastFreeCellRow& > 0) Then
        Cells(LastFreeCellRow&, 1).Activate
    Else
        ' last row not found
    End If
End Sub


' ---------------------------------------------------------------------------------------
' Vor nicht langer Zeit habe ich etwas ehliches fur einen anderen Forum-Besucher
' gemacht, hier der Code (vielleich kann es fur dich nutzlich sein. Mfg Dan
' dusek@cb.vakjc.cz) :

Option Explicit

' Makro startet man mit der Proc MehrereDateienAuslesen(). Einfach im Excel Alt+F8 drucken und den Namen MehrereDateienAuslesen auswahlen
' und auf Taste Run drucken...

' Makro bildet eine neue Datei mit dem Namen GesamttabelleName$ (jetzt "Gesamttabelle.xls")
' In diese Datei werden die Daten aus den bearbeiteten Dateien, aus dem Bereich BereichZumKopieren$ (jetzt "a1 : a12") kopiert
' Die bearbeiteten Dateine werden aus Verzeichnis Verz$ (jetzt "D:\Daten\test") geoffnet

' Falls man etwas ander braucht, z.B. den Bereich, muss man einfach die Const BereichZumKopieren$ andern. Z.B. so :
' Private Const BereichZumKopieren$ = "b1 : b10" - jetzt wird immer der Bereich "b1 : b10" ausgelesen und in die Datei
' "Gesamttabelle.xls" kopiert.

Private Const Verz$ = "D:\daten\test"
Private Const BereichZumKopieren$ = "a1 : a12"
Private Const ExLetzteZeile& = 65536
Private Const GesamttabelleName$ = "Gesamttabelle.xls"
Private Gesamttabelle As Workbook

Public

Sub MehrereDateienAuslesen() ' Starting Proc
    Dim Fso As FileSystemObject
    Dim Fld As Folder
    Dim Fl As File, FlNr%
    
    On Error GoTo ErrH
    
    Set Gesamttabelle = Excel.Workbooks.Add
    Gesamttabelle.SaveAs (Verz$ & "\" & GesamttabelleName$)
        
    Set Fso = New FileSystemObject
    Set Fld = Fso.GetFolder(Verz$)
    FlNr% = 0
    
    For Each Fl In Fld.Files
        If (Right(Fl.Name, 3) = "xls" And _
            Fl.Name <> GesamttabelleName$) Then FlNr% = FlNr% + 1: Call DateiBeareiten(Fl, FlNr%)
    Next Fl
    
    MsgBox "Das Makro hat den Verzeichnis <" & Verz$ & "> durchgesucht." & vbCrLf & _
           "Es sind " & FlNr% & " Excel Dateien bearbeitet worden."
    Application.DisplayAlerts = True
    
    Exit Sub
ErrH:
    MsgBox "Laufzeitsfehler " & Err.Description
    
End Sub


Public

Sub DateiBeareiten(ByVal Datei As File, ByVal DateiNr%)
    Dim WrbAktuell As Workbook, RngZumKop As Range
    Static InZeile&
    
    On Error GoTo ErrH
    
    Set WrbAktuell = Excel.Workbooks.Open(Datei.Path)
    
        ' Daten aus aktuellen Workbook-Sheet1 ins Gesamttabelle kopieren
    Set RngZumKop = WrbAktuell.Worksheets(1).Range(BereichZumKopieren$)
    
    If (DateiNr% = 1) Then InZeile& = 0
    
    If (InZeile& = 0) Then
        RngZumKop.Copy Gesamttabelle.Worksheets(1).Range("a1")
        InZeile& = RngZumKop.Rows.Count + 1
    Else
        If (InZeile& + RngZumKop.Rows.Count <= ExLetzteZeile&) Then
            RngZumKop.Copy Gesamttabelle.Worksheets(1).Cells(InZeile&, 1)
            InZeile& = InZeile& + RngZumKop.Rows.Count
        Else
            MsgBox "Nicht genugend Zeilen. Ende.": End
        End If
    End If
    
    Application.DisplayAlerts = False
    WrbAktuell.Close
    Set WrbAktuell = Nothing
    
    Exit Sub
    
ErrH:
    If (Err.Number = 1004) Then ' Protected Workbook, schlechtes Passw.
        If (MsgBox("Password ist fals, nochmals versuchen???", vbYesNo + vbCritical) = vbYes) Then
            Resume
        Else
            If (Not WrbAktuell Is Nothing) Then WrbAktuell.Close
            Exit Sub
        End If
    Else
        MsgBox "Laufzeitsfehler " & Err.Description
        If (Not WrbAktuell Is Nothing) Then WrbAktuell.Close
    End If
End Sub



Bild


Betrifft: AW: Daten kopieren aus mehreren Dateien
von: Torsten K.
Geschrieben am: 06.11.2003 14:01:03

Hallo Dan,

zunächst einmal vielen Dank für die Mühe, die Du Dir gemacht hast.
Mit Deinen Antworten habe ich allerdings so meine Probleme:

Ermittlung, wie groß der Bereich ist:
Mit dem Code werde ich wohl nicht klar kommen, da in dem Range, den ich genannt habe, sehr wohl Leerspalten vorhanden sind. War wohl mein Fehler, nicht darauf hingewiesen zu haben. Was mach' ich also jetzt an der Stelle?

Ermittlung der letzten Zeile:
Erscheint mir ziemlich kompliziert (ich bin allerdings auch noch ein "Rookie"). Im Prinzip braucht Excel doch nur in der Spalte A nach der nächsten leeren Zelle zu suchen, die dann als Ausgangspunkt für das Einfügen der kopierten Daten dient.

Also, im Augenblick weiß ich noch nicht so recht, wie ich Deine Tips verarbeiten soll.

Gruß
Torsten


Bild


Betrifft: AW: Daten kopieren aus mehreren Dateien
von: Dan
Geschrieben am: 06.11.2003 14:43:56

Hallo Torsten,
auch ein rookie kann das Fliegen lernen ;-)
Hat dir das Code von Michael Brueggemann geholfen? Falls du noch Fragen hast, dann schreib mir eine e-mail. Fragen sollten zwar im Forum gelost werden, aber man kann die Fragen auch ausserhalb des Forum genauso gut losen :-). Ich muss jetzt leider gehen, also antworten konnte ich erst Morgen :-). Viel Gluck, Dan mailto : dusek@cb.vakjc.cz


Bild


Betrifft: AW: Daten kopieren aus mehreren Dateien
von: Torsten K.
Geschrieben am: 06.11.2003 14:53:02

Hi Dan,

schönen dank für Dein Angebot, Fragen direkt an Dich zu mailen.
In der Tat versuche ich gerade den Code von Michael Brüggemann bei mir einzubinden.
Ich denke, wenn sich daraus Fragen ergeben, sollte ich die auch zunächst mit Ihm durchgehen. Nochmals vielen Dank und

Gruß
Torsten


Bild


Betrifft: AW: Daten kopieren aus mehreren Dateien
von: Michael Brueggemann
Geschrieben am: 06.11.2003 13:55:47

Hallo Torsten,

hier eine weitere Moeglichkeit:



Option Explicit

' Hier den Pfad der zu importierenden Dateien festlegen
Const strPath As String = "C:\TEMP\XLTEST\"


Sub Importieren()
    Dim intNaechsteZeile, intOEM_Nummer, intAnzahlZeilen As Integer
    Dim wkbUpload As Workbook
    Dim wksDaten, wksUpload As Worksheet
    
    ' Zeiger auf Zielblatt
    Set wksDaten = ThisWorkbook.Sheets("Daten")
    
    ' Naechste zu benutzende Zeile des Zielblattes ermitteln
    intNaechsteZeile = wksDaten.UsedRange.Rows.Count + 1
    ' vermeiden, dass Meldung Warnmeldungen, wie
    ' "Es befinden sich viele Daten in der Zwischenablage ..."
    ' angezeigt werden
    Application.DisplayAlerts = False
    
    ' Exmplarisch nur fuer die "OEM*" Dateien
    For intOEM_Nummer = 1 To 14
    
        ' Zeiger auf zu importierendes Workbook setzen
        ' (wird spaeter nur zum Schließen des WB verwendet)
        Set wkbUpload = Workbooks.Open(strPath & "OEM_" & intOEM_Nummer)
        
        ' Zeiger auf das zu importierende Sheet setzen
        Set wksUpload = wkbUpload.Sheets("Upload")
        
        ' Anzahl zu importierender Zeilen ermitteln
        intAnzahlZeilen = wksUpload.UsedRange.Rows.Count
        
        ' Bereich von $A$4 bis $DD$AnzahlZeilen kopieren ...
        wksUpload.Range(Cells(4, 1), Cells(intAnzahlZeilen, 108)).Copy
        
        ' ... und in Zielsheet einfuegen
        wksDaten.Paste Destination:=wksDaten.Range("$A$" & intNaechsteZeile)
        
        ' Quell Workbook schließen
        wkbUpload.Close savechanges:=False
        
        ' naechste Zeile im Zielsheet neu festlegen
        intNaechsteZeile = intNaechsteZeile + intAnzahlZeilen - 3
        
    Next intOEM_Nummer
    
    ' Anzeigen von Warnmeldungen wieder aktivieren
    Application.DisplayAlerts = False
End Sub



CIAO
Michael


Bild


Betrifft: AW: Daten kopieren aus mehreren Dateien
von: Torsten K.
Geschrieben am: 06.11.2003 16:30:08

Hallo Michael,

vielen Dank für Deinen Lösungsvorschlag, mit dem ich besser zurechtkomme, als mit dem von Dan.
Ich habe jetzt Deinen Code mit Bestandteilen von anderen gemixt (ich hab' das in der Vergangenheit auch schon ein paar Mal so gemacht und bin dabei eigentlich ganz gut gefahren), bleibe jetzt aber einer Stelle hängen, die aus Deiner Lösung stammt: Und zwar erhalte ich eine Fehlermeldung an der Stelle "wksDate.Paste Destination:=wksDaten.Range."
=> "Fehler beim Kompilieren. Benanntes Argument nicht gefunden". Excel markiert dabei den Begriff "Destination".
Kannst Du hier mal drüberschauen und mir weiterhelfen?
Vielen Dank vorab.

Gruß

Torsten


Private Sub cmb_IMSO_Click()
Dim i As Integer
Dim wkb As Workbook
Dim wkbUpload As Workbook  'Dateien, aus welcher die Daten heraus kopiert werden sollen
Dim wksUpload As Worksheet 'WS, aus dem die Daten heraus kopiert werden sollen (Upload"
Dim wkbZiel As Workbook   'Datei, in welche die Daten eingefügt werden sollen (COPA_IMSO)
Dim wksDaten As Worksheet  'WS, in das die Daten eingefügt werden sollen
Dim rngQuell As Range
Dim intNächsteZeile As Integer
Dim intAnzahlZeilen As Integer
If GetPassword = True Then
Application.ScreenUpdating = False
Application.StatusBar = "Der Vorgang wird u.U. einige Minuten dauern. Geduld bitte!"
Set wkbZiel = Workbooks.Open(strPath & "COPA_IMSO", _
                password:="", WriteResPassword:="")  'öffnet Zieldatei
Set wksDaten = ThisWorkbook.Sheets("Daten")
intNächsteZeile = wksDaten.UsedRange.Rows.Count + 1  'ermittelt nächste zu nutzende Zeile
Application.DisplayAlerts = False
With Application.FileSearch
    .LookIn = "Y:\Budget 2004\Turnover_ADMIN\COPA_Upload\"
    .SearchSubFolders = False
    .Filename = "OEM_*"
    If .Execute > 0 Then
        For i = 1 To .FoundFiles.Count
            Workbooks.Open Filename:=.FoundFiles(i)
            Set wksUpload = wkbUpload.Sheets("Upload")
            intAnzahlZeilen = wksUpload.UsedRange.Rows.Count
            'ermittelt Anzahl zu kopierender Zeilen
            wksUpload.Range(Cells(4, 1), Cells(intAnzahlZeilen, 108)).Copy
            wksDaten.PasteSpecial Destination:=wksDaten.Range("$A$" & intNächsteZeile)
            Application.CutCopyMode = False
            Activewokbook.Close savechanges:=False
            intNächsteZeile = intNächsteZeilen + intAnzahlZeilen - 3
            'berechnet nächste Zeile im wksDaten
            wkbZiel.Save
        Next i
    End If
End With
wkbZiel.Close
Else
    MsgBox "Password ist falsch"
End If
Application.DisplayAlerts = True
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "COPA-Datei wurde aktualsiert"
End Sub



Bild


Betrifft: AW: Daten kopieren aus mehreren Dateien
von: Michael Brueggemann
Geschrieben am: 07.11.2003 09:58:38

Hallo Torsten,

ich war davon ausgegangen, dass das Makro sich im Workbook "COPA_IMSO" befindet. Daher die Anweisung

Set wksDaten = ThisWorkbook.Sheets("Daten")

Da Du jedoch aus dem Workbook, in dem das Makro laeuft, das "COPA_IMSO" erst oeffnest, musst Du

Set wksDaten = wkbZiel.Sheets("Daten")

verwenden.


CIAO
Michael


Bild

Beiträge aus den Excel-Beispielen zum Thema " Daten kopieren aus mehreren Dateien"