13.08.2019

4661

Excel nach bestimmten Schema durchlaufen und Daten kopieren

Hallo zusammen,

Ich habe eine Excel Datei, die wie ungefähr so aufgebaut ist:

Dabei stellt die Range zwischen Start und Ende immer einen Datensatz da, den ich so in ein neues Excel Dokument kopieren möchte.
Bei Start steht immer der Name der jeweiligen Einrichtung.
Daran soll erkannt werden, welche Datenblöcke mit ins neue Excel Dokument kopiert werden.

Diese rohe Excel Datei besteht aus einer "Liste" von Einrichtungsblöcken, wobei dich diese nun in jeweils eigene Dateien kopieren möchte.

Dabei ist die Datei so Aufgebaut, das am Start des Blocks der Name der Einrichung steht und am Ende des Blocks immer Die Summe der Kosten.
Danach folgen immer 7 Zeilen die unwichtig sind bevor der nächste Block startet.

Der Prozess wird aus einer VB.Net Application angestoßen. Wobei ich mir vorstellen kann, das die Verarbeitung der Daten in Excel mit VBA vorgenommen werden könnte (Einfacher als es in VB.Net zu schreiben???)

Unter anderem bin ich mir jetzt noch sicher wie man diese Aufgabe am besten angeht.

Ich könnte jetzt sagen (Pseudocode):

Fange einen Loop ab Range B15 an (Start des ersten Blocks im Dokument) -> Schreibe den Text in eine Variable "NameEinrichtung"  
und Loope bis in Range B das Stichwort "Summe für" auftaucht und kopiere diesen Datensatz in ein neues Exceldokument bzw. eine neue Tabelle.  
Nimm dann Range wo Stichwort "Summe für" und addiere + 8 -> Start des neuen Block  
Wenn NameEinrichtung == B(Start des neuen Blocks) dann
Loope Bis Range B = "Summe für" und kopiere Daten in Tabelle wo NameEinrichtung  
Else 
NameEinrichtung = B (Start des neuen Blocks)
erstelle Tablle NameEinrichtung
Loope Bis Range B = "Summe für" und kopiere Daten in Tabelle wo NameEinrichtung  

Wenn Ende der Excel erreicht ist, dann speicher alle Tabellen als eigene Excel Dateien ab.

Wäre das ein Weg den man gehen könnte, oder gibt es da effizientere Wege?

Kann man das genauso gut in VB.net machen oder macht sich sowas in VBA etwas komfortabler (obwohl sich beide ja ziemlich gleich sind)?

Weitere Infos: Die Excel Datei wird aus einem externen Programm heraus generiert. In meiner VB.Net Application würde ich diese generierte Datei auswählen und auf einen Button "Listen erstellen" drücken, der dann den Prozess ausführt.

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 484536

Url: https://administrator.de/forum/excel-nach-bestimmten-schema-durchlaufen-und-daten-kopieren-484536.html

Ausgedruckt am: 26.04.2025 um 08:04 Uhr

15 Kommentare

Neuester Kommentar

Wat für dich zum fertsch machen (Speicherung der erzeugten Mappen unter deinen gewünschten Dateinamen kannst du ja hoffentlich noch selbst ergänzen

)

Imports Microsoft.Office.Interop
Public Class Form1

    Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
        Dim xl As New Excel.Application, wb As Excel.Workbook, ws As Excel.Worksheet, result As Excel.Range, rngStart As Excel.Range, rngEnd As Excel.Range
        xl.Visible = True
        wb = xl.Workbooks.Open("D:\test.xlsx")  
        ws = wb.Sheets(1)

        With ws.Range("A15:A" & ws.UsedRange.SpecialCells(Excel.XlCellType.xlCellTypeLastCell).Row)  
            result = .Find("Fallname", , Excel.XlFindLookIn.xlValues)  
            If Not result Is Nothing Then
                Dim firstAddress As String = result.Address

                Do
                    rngStart = result.Offset(-1, 0)
                    rngEnd = result
                    While Not rngEnd.Text.Contains("Summe")  
                        rngEnd = rngEnd.Offset(1, 0)
                    End While

                    If Not rngEnd Is Nothing Then
                        Dim newWB As Excel.Workbook = xl.Workbooks.Add()
                        ws.Range(rngStart, rngEnd.Offset(0, ws.UsedRange.Columns.Count)).Copy()
                        With newWB.Sheets(1).Range("A1")  
                            .PasteSpecial(Excel.XlPasteType.xlPasteColumnWidths)
                            .PasteSpecial(Excel.XlPasteType.xlPasteAll)
                        End With

                    End If
                    result = .FindNext(result)
                Loop While Not result Is Nothing And result.Address <> firstAddress
            End If
        End With
    End Sub
End Class

Wow super, das ist schonmal eine große Hilfe.

Da die Zelle B15 mehr enthält als nur den Namen der Einrichtung (unter anderem auch die Adresse), habe ich definition von result so abgeändert:

result = .Find("ANKER Sozialarbeit Gemeinnützige GmbH", , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart)  

wobei der xlPart Teil eigentlich ja wie "Text.Contains" funktionieren sollte. Allerdings findet er bei mir nichts.

Die Zelle sieht unter anderem so aus:

ANKER Sozialarbeit Gemeinnützige GmbH
Muster Str. 77 b
19000 Musterhausen

Funktioniert das dort anders mit xlPart oder warum findet er nicht den Eintrag in der Zelle?

Weil im Beispiel-Code oben nur Spalte A ab Zeile 15 - Ende durchsucht wird

Zitat von @140777:

Weil im Beispiel-Code oben nur Spalte A ab Zeile 15 - Ende durchsucht wird

Sorry, hatte vergessen den Code darüber zu posten:

            With ws.Range("B15:B" & ws.UsedRange.SpecialCells(Excel.XlCellType.xlCellTypeLastCell).Row)  
                result = .Find("ANKER Sozialarbeit Gemeinnützige GmbH", , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart)  

So hab ich es stehen und er findet nichts.

Die Zelle ist verbunden oder passe mal den MatchCase an, kommt der Inhalt aus einer Formel?

Zitat von @140777:

Die Zelle ist verbunden oder passe mal den MatchCase an, kommt der Inhalt aus einer Formel?

genau die Zelle ist verbunden und hat einen Textumbruch drin.

Der Inhalt steht as Value drin, also nicht per Formel

Zitat von @Pat.bat:
genau die Zelle ist verbunden und hat einen Textumbruch drin.

Da hast du deinen Grund, darin findet der nichts wenn man den Suchbereich nicht auf alle Spalten der Verbundenen ausweitet. Deswegen habe ich nach der eindeutigen Spaltenbeschriftung "Fallnummer" gesucht und dann die Zelle eins nach oben geschoben

, eine Adresse oder Name kann sich ja ändern.
Du kannst auch einen anderen festen Bezug nehmen und dann einen anderen Offset davon definieren.

Zitat von @140777:

Zitat von @Pat.bat:
genau die Zelle ist verbunden und hat einen Textumbruch drin.

, eine Adresse oder Name kann sich ja ändern.

Mit Fallname findet er trotzdem nichts.

Aber wenn ich nach Fallname suche und sage er soll eine Zelle hoch rutschen und ab da an bis Summe alles kopieren, woher weiss er dann den Einrichtungsnamen und kann damit eine neue Tabelle erstellen?

Zum Hintergrund:

Eine Einrichtung hat einen Namen, wie hier zb. "ANKER Sozialarbeit Gemeinnützige GmbH".
Eine Einrichtung kann aber mehrere Standorte haben. D.h. alle Blöcke mit dem Namen der Einrichtung unabhängig von der Adresse sollen in eine neue Tabelle kopiert werden.

Daher meine Überlegung, die Zelle B15 mit einer Art Contains zu überprüfen. Der Name der jeweiligen Einrichtung ist immer gleich, aber die Adresse kann unterschiedlich sein.

Nachtrag:

Achso jetzt weiß ich was du bezwecken wolltest. Er zieht sich also die Zelle über Fallname und nimmt diese als Anhaltspunkt weitere Blöcke zu finden, die mit dem selben Wert anfangen.

Nur gibt es wie gesagt, 2 Probleme. Auch mit Fallname findet er nichts und der Name ist gleich, nur die Adresse ist unterschiedlich.

Zitat von @Pat.bat:
Mit Fallname findet er trotzdem nichts.

Dann ist die wohl auch verbunden. Funktioniert hier testweise einwandfrei, ohne Quelldaten vorliegen zu haben kann man ja leider nur raten.

Aber wenn ich nach Fallname suche und sage er soll eine Zelle hoch rutschen und ab da an bis Summe alles kopieren, woher weiss er dann den Einrichtungsnamen und kann damit eine neue Tabelle erstellen?

Mit entsprechendem Offset kein Problem
Wenn hier so viel mit Zellverbunden gearbeitet wird wirst du wohl doch auf eine Schleife ausweichen müssen außer du findest noch ein Merkmal jedes Datensatzes in dieser oder einer anderen Spalte anhand dessen man über einen Offset die Anfangszelle bestimmen kann.

Zitat von @140777:

Zitat von @Pat.bat:
Mit Fallname findet er trotzdem nichts.

Dann ist die wohl auch verbunden. Funktioniert hier testweise einwandfrei, ohne Quelldaten vorliegen zu haben kann man ja leider nur raten.

es gibt da noch Spalte N wo das Wort betrag steht. Die Zelle ist nicht verbunden, aber als Textumbruch eingestellt.

Dort habe ich den Code dann wie folgt abgeändert, aber scheint in eine Endlosschleife zu laufen:

With ws.Range("N16:N" & ws.UsedRange.SpecialCells(Excel.XlCellType.xlCellTypeLastCell).Row)  
                result = .Find("Betrag", , Excel.XlFindLookIn.xlValues)  
                If Not result Is Nothing Then
                    Dim firstAddress As String = result.Address

                    Do
                        rngStart = result.Offset(-1, -7)
                        rngEnd = result
                        While Not rngEnd.Text.Contains("Summe")  
                            rngEnd = rngEnd.Offset(1, 0)
                        End While

Der Name der Einrichtung befindet sich in Zelle B15 (Verbunden und Textumbruch)

Geht so auch nicht.
Wie gesagt mach's mit einfacher Schleife über eine Spalte oder löse den Verbund der Zellen temporär im Code für die Suche. Ohne das Quell-Sheet leider immer noch Glaskugel.

Dim xl As New Excel.Application, wb As Excel.Workbook, ws As Excel.Worksheet, rngStart As Excel.Range, rngEnd As Excel.Range
Dim searchEnd As Boolean = False
xl.Visible = True
wb = xl.Workbooks.Open("D:\Testexport.xlsx")  
ws = wb.Sheets(1)

For Each cell As Excel.Range In ws.Range("B15:B" & ws.UsedRange.SpecialCells(Excel.XlCellType.xlCellTypeLastCell).Row)  
    If searchEnd Then
        If cell.Text.Contains("Summe") Then  
            searchEnd = False
            rngEnd = cell

            Dim newWB As Excel.Workbook = xl.Workbooks.Add()
            ws.Range(rngStart, rngEnd.Offset(0, ws.UsedRange.Columns.Count)).Copy()
            With newWB.Sheets(1).Range("A1")  
                .PasteSpecial(Excel.XlPasteType.xlPasteColumnWidths)
                .PasteSpecial(Excel.XlPasteType.xlPasteAll)
            End With
        End If
    Else
        If cell.Value = "Fallname" Then  
            searchEnd = True
            rngStart = cell.Offset(-1, 0)
        End If
    End If 
Next

Hallo,

ich habe die Datei mal soweit es geht anonymisiert

Testexcel.xlsx

Mit folgendem Stück code bekomme ich zumindest nun die richtigen Zellen:

            With ws.Range("N15:N" & ws.UsedRange.SpecialCells(Excel.XlCellType.xlCellTypeLastCell).Row)  
                result = .Find("Betrag", , Excel.XlFindLookIn.xlValues)  
                If Not result Is Nothing Then
                    Dim firstAddress As String = result.Address

                    Do
                        rngStart = result.Offset(-1, -12)
                        MessageBox.Show(rngStart.Text.ToString)
                        rngEnd = result
                        While Not rngEnd.Text.Contains("Summe")  
                            rngEnd = rngEnd.Offset(1, -12)
                            MessageBox.Show(rngEnd.Text.ToString)
                        End While

Allerdings gibts eine Exception nach dem ersten While durchlauf:

Hatte den angepassten Code für die Sub nachträglich im letzten Kommentar gepostet, damit funktioniert es hier im Test mit deiner bereitgestellten Datei (Danke!).

Zitat von @140777:

Hatte den angepassten Code für die Sub nachträglich im letzten Kommentar gepostet, damit funktioniert es hier im Test mit deiner bereitgestellten Datei (Danke!).

Danke, mit folgenden Änderungen funktioniert es nun perfekt in der VB App:

Dim xl As New Excel.Application, wb As Excel.Workbook, ws As Excel.Worksheet, rngStart As Excel.Range, rngEnd As Excel.Range
            Dim searchEnd As Boolean = False
            xl.Visible = False
            xl.DisplayAlerts = False
            wb = xl.Workbooks.Open(Application.StartupPath & "\export.xlsx")  
            ws = wb.Sheets(1)

            For Each cell As Excel.Range In ws.Range("B15:B" & ws.UsedRange.SpecialCells(Excel.XlCellType.xlCellTypeLastCell).Row)  
                If searchEnd Then
                    If cell.Text.Contains("Summe") Then  
                        searchEnd = False
                        rngEnd = cell

                        Dim newWB As Excel.Workbook = xl.Workbooks.Add()
                        ws.Range(rngStart, rngEnd.Offset(0, ws.UsedRange.Columns.Count)).Copy()
                        With newWB.Sheets(1).Range("A1")  
                            .PasteSpecial(Excel.XlPasteType.xlPasteColumnWidths)
                            .PasteSpecial(Excel.XlPasteType.xlPasteAll)
                        End With

                        Dim FileName As String = cell.Text.ToString.Substring(10)
                        FileName = FileName.Replace(Chr(34), "") ' Doppeltes Anführungszeichen aus Dateiname löschen, da dies nicht zulässig ist              
                        Dim SavePath As String = Application.StartupPath & "\Zahllisten\" & FileName & ".xlsx"  
                        newWB.SaveAs(SavePath, FileFormat:=51) ' 51 = xlsx, 57 = PDF  
                        newWB.Close()

                    End If
                Else
                    If cell.Value = "Fallname" Then  
                        searchEnd = True
                        rngStart = cell.Offset(-1, 0)
                    End If
                End If
            Next

            xl.Quit()

Jetzt hab ich noch die Aufgabe bekommen, das ganze in PowerShell zu schreiben, damit dieses Stück Code auch als Teil eines Batches ausgeführt werden kann (Windows Aufgabenplanung). Puh, jetzt muss ich erstmal schauen wie man sowas in PowerShell macht.

Trotzdem vielen Dank für die super Hilfe hier