spikeee
Goto Top

VBA-Excel Tabellen verschieben bzw splitten problem

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.
3e76a08ff851fa0b1cfaafa930c7bd43
4903d8043af1be092a023ab9f39562eb

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

Content-Key: 278161

Url: https://administrator.de/contentid/278161

Ausgedruckt am: 28.03.2024 um 12:03 Uhr

Mitglied: colinardo
colinardo 23.07.2015 aktualisiert um 17:04:14 Uhr
Goto Top
Hallo Spikeee,
ist doch halb so wild face-smile daten_uebertragen_278161.xlsm

Grüße Uwe
Mitglied: Spikeee
Spikeee 24.07.2015 um 12:09:28 Uhr
Goto Top
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.
Mitglied: colinardo
colinardo 24.07.2015 aktualisiert um 12:43:02 Uhr
Goto Top
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!
Mitglied: Spikeee
Spikeee 24.07.2015 um 13:36:42 Uhr
Goto Top
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
Mitglied: colinardo
colinardo 24.07.2015 aktualisiert um 13:39:58 Uhr
Goto Top
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
Mitglied: colinardo
Lösung colinardo 24.07.2015, aktualisiert am 24.02.2024 um 19:50:09 Uhr
Goto Top
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
Mitglied: Spikeee
Spikeee 27.07.2015 um 09:22:13 Uhr
Goto Top
Hammer! Vielen vielen dank, hätte nie gedacht, dass da soviel Aufwand hinter steckt! Funktioniert einwandfrei!
Mitglied: colinardo
colinardo 27.07.2015 aktualisiert um 09:40:50 Uhr
Goto Top
Zitat von @Spikeee:

Hammer! Vielen vielen dank, hätte nie gedacht, dass da soviel Aufwand hinter steckt! Funktioniert einwandfrei!
Aber auch nur wegen eurem Tabellenaufbau face-wink Mit zwei ListObject-Tabellen auf dem Rechnungssheet hätte man das viel eleganter lösen können.

Grüße Uwe