Daten mehrerer Formulare aus Zellen auslesen und in ein neues Formular übertragen

Question

Ich habe im Forum einen Beitrag durchgelesen und bin dabei auf eine interessante Frage zum Thema zusammenführen mehrere Excel-Formulare gestoßen.

Auf dem Schulserver werden die Excel-Arbeitsblätter abgespeichert und ich möchte nun die eingegeben Daten der SchülerInnen auslesen:

'und Inhalt des ersten Blatts in das erste Blatt der aktuellen Arbeitsmappe kopieren

             Workbooks(DateiName).Sheets(1).UsedRange.Copy ThisWorkbook.Worksheets(1).Range("A" & ThisWorkbook.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1)

(die Formel stammt übrigens vom Forumsmitglied M.O.; ich habe nur einen Teil wiedergegeben).

Das funktioniert wunderbar, allerdings wird die ganze Seite ausgelesen und in die neue Arbeitsmappe eingetragen. Ich möchte aber nur bestimmte Zellenwerte (z. B. A2, B4, E8,...; wo eben die Ergebnisse stehen) auslesen und zeilenweise in die neue Arbeitsmappe übertragen. Wahrscheinlich muss man nur eine Kleinigkeit ändern, aber da bin ich mit meinen Kenntnissen schon überfordert.

Danke Robert

Vielleicht habe ich um zu viele Ecken gedacht: ich ordne die Ergebnisse den Zellen z. B. In Zeile 25 jeder Arbeitsmappe zu. Dann müsste nur diese Zeile von allen abgegebenen Arbeitsmappen eingelesen und zugeordnet werden.

Answer 1

Hallo Robert,

wenn du nur bestimmte Zellen aus einer Mappe in eine andere Mappe kopieren willst, dann kannst du das so machen (Beispiel):

ThisWorkbook.Worksheets("Zusammenfassung").Cells(1, 1) = Workbooks(Dateiname).Worksheets(1).Range("A1")

Damit wird aus der geöffneten Arbeitsmappe aus der 1. Tabelle die Zelle A1 in die Arbeitsmappe, in der der VBA-Code steht, in die Zelle A1 der Tabelle Zusammenfassung kopiert.

Da du ja mehrere Arbeitsmappen auslesen willst, müsstest du das über eine Schleife machen, also z.B. so:

ThisWorkbook.Worksheets("Zusammenfassung").Cells(lngZeile, 1) = Workbooks(Dateiname).Worksheets(1).Range("A1")

Wobei lngZeile die Einfügezeile ist und per Schleife mit jeder Arbeitsmappe, die du öffnest, erhöht wird, so dass die Ergebnisse untereinander stehen. Und damit du auch weißt, aus welcher Arbeitsmappe das Ergebnis ausgelesen wurde (z.B. Name des Schülers = Arbeitsmappenname) schreibt man am Besten noch den Namen davor:

ThisWorkbook.Worksheets("Zusammenfassung").Cells(lngZeile, 1) = Dateiname

ThisWorkbook.Worksheets("Zusammenfassung").Cells(lngZeile, 2) = Workbooks(Dateiname).Worksheets(1).Range("A1")

Falls du nicht weiterkommst, dann schreibe einfach mal, welche Zellen aus den Dateien ausgelesen werden sollen.

Gruß

M.O.

Answer 2

Hallo M.O.

Habe die untenstehende Formel entsprechend deinen Anweisungen abgeändert, aber es will nicht so recht.

Daher poste ich deine Formel, die ich in einem anderen Beitrag gefunden habe:

Private Sub CommandButton1_Click()

Dim DateiName As String

Dim strPfad As String

strPfad = "C:\Users\rmair\Documents\exc\"

With Application

        .ScreenUpdating = False

        .EnableEvents = False

End With

DateiName = Dir(strPfad & "*.xl*")

    Do While DateiName <> ""

        If ThisWorkbook.Name <> DateiName Then

         If Left(DateiName, 3) = "2A_" Then

            Workbooks.Open Filename:=strPfad & DateiName

             Workbooks(DateiName).Sheets(1).UsedRange.Copy ThisWorkbook.Worksheets(1).Range("A" & ThisWorkbook.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1)

            Workbooks(DateiName).Close SaveChanges:=False

  End If

        End If

        DateiName = Dir

    Loop


With Application

        .ScreenUpdating = True

        .EnableEvents = True

End With

End Sub

Diese habe ich mittlerweile meinen Bedürfnissen angepasst. Ich möchte es so regeln, dass die ausgeteilten Excel-Arbeitsmappen von den Schülern bearbeitet werden und sie diese dann auf einem gemeinsamen Ordner abspeichern (alle Mappen beginnen mit "2A_"). Das Arbeitsblatt ist so gestaltet, dass die Ergebnisse in Zeile 25 abgespeichert werden (A25: Name, B25: Ergebnis 1,C25: Ergebnis 2,...; alternativ kann ich diese auch in einer Spalte abbilden). Diese Zeile soll abgerufen und kopiert werden und dann in meine Arbeitsmappe, beginnend ab der 2. Zeile gespeichert werden. Damit könnte ich mir viel Arbeit ersparen, da ich nicht jede abgegebene Arbeitsmappe extra öffnen muss.

Da wir auch mit One-Note arbeiten, müsste ich in diesen Klassen den Link, der auf den entsprechenden Ordner verweist, einfügen.

Danke Robert

Answer 3

Hallo Robert,

ob die Daten aus einer Zeile oder Spalte kopiert werden sollen, ist egal .

Ich werde den Code entsprechend anpassen.

Gruß

M.O.

Answer 4

Hallo Robert,

probiere mal das folgende Makro:

Sub kopieren()

Dim DateiName As String
Dim strPfad As String
Dim lngEinfZeile As Long

strPfad = "C:\Users\rmair\Documents\exc\"

With Application

        .ScreenUpdating = False

        .EnableEvents = False

End With

DateiName = Dir(strPfad & "*.xl*")

    Do While DateiName <> ""

        If ThisWorkbook.Name <> DateiName Then

         If Left(DateiName, 3) = "2A_" Then
            
            EinfZeile = EinfZeile + 1    'Zähler für Einfügezeile um 1 erhöhen
            Workbooks.Open Filename:=strPfad & DateiName
            Workbooks(DateiName).Sheets(1).Rows(25).Copy Destination:=ThisWorkbook.Worksheets(1).Rows(EinfZeile)
            Workbooks(DateiName).Close SaveChanges:=False  'geöffnete wieder schließen, ohne Speicherung

  End If

        End If

        DateiName = Dir

    Loop

With Application

        .ScreenUpdating = True

        .EnableEvents = True

End With

End Sub

Die kopierten Daten werden in das erste Blatt ab Zeile 1 der Mappe eingefügt, in der das Makro steht.

Gruß

M.O.

Answer 5

Hallo M.O.

Wie immer sind deine Lösungen perfekt. Damit ist es für mich eine große Arbeitserleichterung, da ich sämtliche abgegebenen Arbeitsmappen mit einem Klick auf ihre Richtigkeit hin überprüfen kann. Da wir in unseren digitalen Klassen mit One-Note arbeiten, lasse ich die Arbeitsmappen auf einem freigegebenen Ordner auf Dropbox speichern, damit die Ergebnisse abgerufen werden können (mit dem Link hat es nicht geklappt; vermutlich wird jede Mappe unter einem eigenen Link auf One-Note abgespeichert).

Nun habe ich dank deiner großartigen Hilfe viele Arbeitsmappen entworfen und stelle diese zu Übungszwecken meinen Schützlingen zur Verfügung. Das ist zugleich Ansporn für mich, bevor es im nächsten Jahr in die Rente geht.

Dann nehme ich mir die Zeit, mich mehr mit vba zu befassen. Versprochen.

Recht herzlichen Dank von Robert

Answer 6

Hallo Robert,

danke für die Rückmeldung und Respekt. Ich hatte das Bild eines jungen Lehrers vor Augen. Blöde Vorurteile .

Gruß

M.O.

Answer 7

Wie es eben so ist: Im Herzen jung und ein bisschen Lausbube. Die Huelle sagt was Anderes.

Answer 8

Das ist das Faszinierende zugleich aber auch das Demoralisierende  an IT!

Ich habe vor fast 2 Monaten die fertige Datei ausprobiert und sie hat wunderbar funktioniert. Jetzt, wo ich sie einsetzen muss, macht der Code nicht das was ich will.

Die Überprüfung mache ich mit folgendem Makro:

Private Sub CommandButton1_Click()

Dim DateiName As String

Dim strPfad As String

Dim lngEinfZeile As Long

strPfad = "C:\Users\rmair\Documents\Probe\"

With Application

        .ScreenUpdating = False

        .EnableEvents = False

End With

DateiName = Dir(strPfad & "*.xl*")

    Do While DateiName <> ""

        If ThisWorkbook.Name <> DateiName Then

         If Left(DateiName, 3) = "ueb" Then      

            EinfZeile = EinfZeile + 1    'Zähler für Einfügezeile um 1 erhöhen

            Workbooks.Open Filename:=strPfad & DateiName

            Workbooks(DateiName).Sheets(1).Rows(30).Copy Destination:=ThisWorkbook.Worksheets(1).Rows(EinfZeile)

            Workbooks(DateiName).Close SaveChanges:=False  'geöffnete wieder schließen, ohne Speicherung

  End If

        End If

        DateiName = Dir

    Loop

With Application

        .ScreenUpdating = True

        .EnableEvents = True

End With

End Sub

Die Dateien sind wie folgt angeordnet (ausgelesen soll jeweils die Zeile 30 werden).

Beim Auslesen zeigt mit die Datei folgende Werte an:

Die ersten beiden Blätter werden richtig ausgelesen, der Rest aber ist fehlerhaft (siehe Beschreibung oben). Blatt 3 (blau eingefärbt) wird versetzt angezeigt. Für die Blätter 4-6 bekomme ich einen Bezugsfehler ausgewiesen.

Sitzt der Fehler vor dem Computer?

Danke Robert

Answer 9

Habe ein neues Blatt angelegt und die Zeilen 30 noch mal neu formatiert (Standard). Jetzt sieht das Ergebnis besser aus, aber leider weist das Blatt nach wie vor viele Bezugsfehler auf!

Blatt 1 hat nur Bezugsfehler,, Blatt 6 und 7" teilweise. Mittels bedingter Formatierung lasse ich die richtigen Lösungen grün einfärben. Idealerweise wäre es besser, wenn das Einlesen erst ab der zweiten Zeile erfolgen würde, um in Zeile 1 die richtigen Ergebnisse zu schreiben.

Robert

Answer 10

Hallo Robert,

der Bezugsfehler deutet darauf hin, dass hier Formeln kopiert werden, die jetzt natürlich nicht mehr funktionieren.

Ich habe das Makro mal so verändert, dass jetzt die Werte ab Zeile 2 eingefügt werden:

Private Sub CommandButton1_Click()

Dim DateiName As String

Dim strPfad As String

Dim lngEinfZeile As Long

strPfad = "C:\Users\rmair\Documents\Probe\"

'Zähler für Einfügezeile auf 1 festlegen, Einfügen erst ab Zeile 2
lngEinfZeile = 1

With Application

        .ScreenUpdating = False

        .EnableEvents = False

End With

DateiName = Dir(strPfad & "*.xl*")

    Do While DateiName <> ""

        If ThisWorkbook.Name <> DateiName Then

         If Left(DateiName, 3) = "ueb" Then

            EinfZeile = EinfZeile + 1    'Zähler für Einfügezeile um 1 erhöhen

            Workbooks.Open Filename:=strPfad & DateiName

            Workbooks(DateiName).Sheets(1).Rows(30).Copy
            'nur Werte einfügen
            ThisWorkbook.Worksheets(1).Rows(EinfZeile).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            Workbooks(DateiName).Close SaveChanges:=False  'geöffnete wieder schließen, ohne Speicherung

  End If

        End If

        DateiName = Dir

    Loop

With Application

        .ScreenUpdating = True

        .EnableEvents = True

End With

End Sub

Probiere mal, ob das Ergebnis jetzt besser ist.

Gruß

M.O.