AW: Falls es unlösbar ist einfach sagen :)
16.10.2019 18:31:21
Dieter
Hallo Birgit,
das wird natürlich etwas komplizierter.
Ich übernehme die Daten zuerst in ein Hilfsblatt, sortiere sie da und baue dann das Blatt "Projektplanung" neu auf.
Das sieht dann so aus:
Sub LeistungenÜbernehmen()
Dim aktLeistung As String
Dim anzLeistBisher As Long
Dim letzteZeileH As Long
Dim letzteZeileQ As Long
Dim letzteZeileZ As Long
Dim bisherLeistung As String
Dim i As Long
Dim sp As Long
Dim transTab As Variant
Dim wsH As Worksheet
Dim wsQ As Worksheet
Dim wsZ As Worksheet
Dim zeileH As Long
Dim zeileQ As Long
Dim zeileZ As Long
Application.ScreenUpdating = False
Set wsH = ThisWorkbook.Worksheets("Hilfsblatt")
wsH.UsedRange.EntireRow.Delete
Set wsQ = ThisWorkbook.Worksheets("Obst")
Set wsZ = ThisWorkbook.Worksheets("Projektplanung")
letzteZeileZ = wsZ.Cells(wsZ.Rows.Count, "W").End(xlUp).Row
If letzteZeileZ 0 Then
' Daten von Projektplanung nach Hilfsblatt übernehmen
letzteZeileZ = wsZ.Cells(wsZ.Rows.Count, "D").End(xlUp).Row
zeileZ = 3
Do Until zeileZ > letzteZeileZ
If Not IsEmpty(wsZ.Cells(zeileZ, "C")) Then
aktLeistung = wsZ.Cells(zeileZ, "C")
zeileZ = zeileZ + 1
Else
Do Until IsEmpty(wsZ.Cells(zeileZ, "D"))
zeileH = zeileH + 1
wsH.Cells(zeileH, "C") = aktLeistung
wsZ.Cells(zeileZ, "D").Resize(, 9).Copy Destination:=wsH.Cells(zeileH, "D")
zeileZ = zeileZ + 1
Loop
End If
Loop
End If
' Neu einzufügende Leistungen dem Hilfsblatt hinzufügen
letzteZeileQ = wsQ.Cells(wsQ.Rows.Count, "B").End(xlUp).Row
For zeileQ = 5 To letzteZeileQ
If wsQ.Cells(zeileQ, "A") = "x" Then
If Len(wsQ.Cells(zeileQ, "B")) > 6 Then
zeileH = zeileH + 1
aktLeistung = Mid$(wsQ.Cells(zeileQ, "B"), 3, 4)
wsH.Cells(zeileH, "C") = WorksheetFunction.VLookup(aktLeistung, transTab, 2, 0)
wsQ.Cells(zeileQ, "B").Resize(, 9).Copy Destination:=wsH.Cells(zeileH, "D")
End If
End If
Next zeileQ
letzteZeileH = zeileH
' Sortierung des Hilfsblattes
With wsH.Sort
With .SortFields
.Clear
.Add Key:=wsH.Range("C1")
.Add Key:=wsH.Range("D1")
End With
.SetRange Rng:=wsH.Range("C1").Resize(letzteZeileH, 10)
.Header = xlNo
.Apply
End With
' Daten aus dem Hilfsblatt nach Projektplanung übernehmen
' Bisherigen Inhalt von Blatt "Projektplanung" löschen
If Not Intersect(wsZ.UsedRange, wsZ.Range("A3").Resize(wsZ.Rows.Count - 2, 12)) Is Nothing _
Then
Intersect(wsZ.UsedRange, wsZ.Range("A3").Resize(wsZ.Rows.Count - 2, 12)).ClearContents
End If
zeileZ = 3
For zeileH = 1 To letzteZeileH
aktLeistung = wsH.Cells(zeileH, "C")
If aktLeistung bisherLeistung Then
' Wechsel der Leistungsart
wsZ.Cells(zeileZ, "C") = aktLeistung
zeileZ = zeileZ + 1
bisherLeistung = aktLeistung
End If
wsH.Cells(zeileH, "D").Resize(, 9).Copy
wsZ.Cells(zeileZ, "D").PasteSpecial Paste:=xlValues
Application.CutCopyMode = xlCut
zeileZ = zeileZ + 1
Next zeileH
Application.ScreenUpdating = True
wsZ.Activate
wsZ.Range("A1").Activate
End Sub
https://www.herber.de/bbs/user/132559.xlsm
Viele Grüße
Dieter