VBA-Excel Tabellen verschieben bzw splitten problem

gelöstFrage VB for Applications Entwicklung

Hallo Liebe Gemeinde!

Ich bin relativer Neuling in VBA Programmierung, versuche mich mit meinem Kollegen aber gerade an einer komplexeren Aufgabe. Leider bislang erfolglos.

Wir haben eine Excel Tabelle mit 2 Tabellenblättern "Liste Aufträge" und "Rechnung". In der ersten Liste sind in der Spalte F verschiedene Arbeitsgruppen (z.B. Meister/Verwaltung und Arbeiter Grünpflege die als "Personal" gelten, sowie Fahrzeuge). Jeder Arbeitsgruppe ist ein Stundensatz und eine Stundenzahl zugeordnet. Nun wollen wir ein Makro schreiben, dass per Klick auf einen Button alle Daten vom "Personal" inkl des Stundensatzes und Betrages in die obere Tabelle des Worksheets "Rechnung" kopiert wird und alle Daten vom "Fahrzeug" in die untere Tabelle.

Alleine für Tipps zur Realisierung wären wir sehr dankbar! Wir hatten bereits mehrere Lösungsansätze haben aber die meisten aber wieder über den Haufen geworfen, weil an irgendeiner Stelle ein unlösbares Problem aufgetaucht ist.

Vielen Dank im Voraus

Spikeee

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

Content-ID: 278161

Url: https://administrator.de/forum/vba-excel-tabellen-verschieben-bzw-splitten-problem-278161.html

Ausgedruckt am: 22.04.2025 um 19:04 Uhr

8 Kommentare

Neuester Kommentar

Hallo Spikeee,
ist doch halb so wild

daten_uebertragen_278161.xlsm

Grüße Uwe

Danke für die schnelle Antwort! Eigentlich wollte ich versuchen deinen Quellcode selbstständig an mein Dokument anzupassen, aber das funktioniert leider nur teilweise.

Folgende Probleme: Die Werte in der ersten Liste sind per Formel zusammengesetzt und müssten beim kopieren in feste Werte umgewandelt werden. Zusätzlich muss die Zählvariable irgendwie zurückgesetzt werden, da nach jedem Klick auf den Butten die Zahlen unten angehangen werden. Jedoch sollen die Zahlen der Liste nach Bearbeitung gelöscht werden (was kein problem darstellt) und dann erneut von Anfang an in die Liste eingetragen werden.

Alles kein Problem wenn man denn weiß was Sache ist und es sein soll , wäre aber für uns wesentlich einfacher wenn du uns das Dokument irgendwo anonymisiert hochladen könntest ... dann gibt es keine fehlenden Infos mehr von deiner Seite, und wir bauen hier nicht jedes mal Code der dir dann doch wieder nicht passt!

Ich dachte den Code selbständig weiterführen zu können und dabei noch ein wenig zu lernen. Leider scheinen meine Grundkenntnisse noch nicht ausreichend zu sein. Habs mal hier hochgeladen http://www7.zippyshare.com/v/fl59w9Gl/file.html

Zitat von @Spikeee:
Ich dachte den Code selbständig weiterführen zu können und dabei noch ein wenig zu lernen.

Ich habe den Code eigentlich kommentiert, aber alles Beibringen kann ich dir hier leider nicht ;-/

Schaus mir später an.

Grüße Uwe

Sodele,
kein Wunder warum Ihr da solche Probleme hattet ... Ohne dein Beispielsheet hätte man da nie was funktionsfähiges anpassen können.

Ausnahmsweise hab ich den Wust mal an dein Sheet angepasst. War nämlich nicht so ohne.
Weitere Kommentare pack ich später noch rein, habe dazu im Moment keine Zeit mehr.

Bitte beachten das die Namen (Bookmarks) auf die Anfangszellen(erste leere Zelle in Spalte A) für Personal und Fahrzeuge im Sheet Rechnung gesetzt werden müssen, sonst funktioniert der Code nicht !! Das hättest du nämlich ebenfalls nicht in deinem Sheet gemacht. Siehe dazu auch Zeile 8 im Code

Ich würde mir dringend mal überlegen euch ein ordentliches Rechnungsprogramm zuzulegen, damit werdet Ihr bestimmt glücklicher als so eine Frickelei in Excel zu fabrizieren...aber jedem das Seine.

Sub ExtractFromList()
    Dim wsSource As Worksheet, wsTarget As Worksheet, rngFahrzeuge As Range, rngPersonal As Range, cell As Range, dblStunden As Double, dblStundensatz As Double, dblBetrag As Double
    'Sheets referenzieren  
    Set wsSource = Sheets("Liste Aufträge")  
    Set wsTarget = Sheets("Rechnung")  
    
    'Startbereiche für die Ausgabe auf dem Rechnungssheet  
    ' => Zur Info es wurden an den Einfügepositionen Bookmarks mit den Namen in den nächsten zwei Zeile gesetzt !  
    Set rngPersonal = wsTarget.Range("personal")  
    Set rngFahrzeuge = wsTarget.Range("fahrzeuge")  
    
    'Zielbereiche löschen  
    rngPersonal.Resize(rngPersonal.End(xlDown).Row - rngPersonal.Row, 5).ClearContents
    rngFahrzeuge.Resize(rngFahrzeuge.End(xlDown).Row - rngFahrzeuge.Row, 5).ClearContents
    
    Application.ScreenUpdating = False
    With wsSource
        ' Personal übertragen  
        .Range("A1").CurrentRegion.AutoFilter Field:=6, Criteria1:="<>*Fahrzeug*", Operator:=xlAnd  
        For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)  
            dblStunden = CDbl(cell.Offset(0, 11).Value)
            dblStundensatz = CDbl(cell.Offset(0, 12).Value)
            dblBetrag = CDbl(cell.Offset(0, 13).Value)
            If rngPersonal.Offset(1, 0).Value <> "" Then  
                rngPersonal.Resize(1, 5).Copy
                rngPersonal.Insert xlShiftDown
                Set rngPersonal = rngPersonal.Offset(-1, 0)
            End If
            rngPersonal.Resize(1, 5).Value = Array(dblStunden, dblStundensatz, "", "=", dblBetrag)  
            Set rngPersonal = rngPersonal.Offset(1, 0)
        Next
        'Überflüssige Leerzeilen im Ziel entfernen  
        With rngPersonal
            .Resize(.End(xlDown).Row - .Row, 1).EntireRow.Delete
        End With

        ' Fahrzeuge kopieren  
        .Range("A1").CurrentRegion.AutoFilter Field:=6, Criteria1:="*Fahrzeug*"  
        For Each cell In wsSource.Range("A2:A" & wsSource.Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)  
            dblStunden = CDbl(cell.Offset(0, 11).Value)
            dblStundensatz = CDbl(cell.Offset(0, 12).Value)
            dblBetrag = CDbl(cell.Offset(0, 13).Value)
            If rngFahrzeuge.Offset(1, 0).Value <> "" Then  
                rngFahrzeuge.Resize(1, 5).Copy
                rngFahrzeuge.Insert xlShiftDown
                Set rngFahrzeuge = rngFahrzeuge.Offset(-1, 0)
            End If
            rngFahrzeuge.Resize(1, 5).Value = Array(dblStunden, dblStundensatz, "", "=", dblBetrag)  
            Set rngFahrzeuge = rngFahrzeuge.Offset(1, 0)
        Next
        
        'Überflüssige Leerzeilen im Ziel entfernen  
        With rngFahrzeuge
            .Resize(.End(xlDown).Row - .Row, 1).EntireRow.Delete
        End With

        
        Application.CutCopyMode = False
        'Filter entfernen  
        .Range("A1").AutoFilter Field:=6  
        Application.ScreenUpdating = True
        wsTarget.Select
    End With
End Sub

Wie immer alles ohne Gewähr. Weitere Anpassungen nur noch gegen Aufwandsentschädigung.

Wenn du es nicht hin bekommst melde dich mit deiner E-Mail Adresse in einer persönlichen Nachricht, dann schicke ich dir das angepasste Sheet mit dem integrierten Code.

Grüße Uwe