Dieter // Gliederung

Hm, irgendwie kam meine Nachricht nicht durch. Dann halt ein zweites Mal :)
Ich würde mich nun dran setzen und die Definition der einzelnen Gruppen in das Blatt "Obst"  _
integrieren, da ich 13 verschiedene Blätter habe und ungern nun 13 verschiedene Hilfsblätter  _
anlegen möchte. Das Umschreiben des Makros bekomme ich vielleicht sogar hin.
Geht das aus deiner Sicht? Wenn nicht, dann würde ich es lassen. :)
Gruß
Birgit
PS: Ich hab mich in meiner ersten Nachricht von Herzen bedankt für deine Unterstützung. :)
Bezieht sich auf diese Nachricht:

Hallo Birgit,
das Problem liegt daran, dass der SVERWEIS (VLOOKUP) in Blatt "Projektplanung" Spalten W und X  _
_
keinen gültigen Wert findet.
Der Wert nach dem gesucht wird, entsteht aus dem entsprechenden Wert in Spalte B von Blatt " _
Obst" einfach dadurch, dass ab Stelle 3 4 Zeichen herausgeschnitten werden. Deine Beispieldaten  _
waren so, dass das funktioniert hat. Vielleicht sind deine Originaldaten komplizierter, dann müsstest du mal ein Beispiel mit den kompletten Möglichkeiten Schicken.
Ich habe das Programm jetzt so ergänzt, dass nicht mehr der Laufzeitfehler erscheint, sondern   _
_
eine programmierte Fehlermeldung. An der Fehlermeldung kannst du erkennen, nach welchem Begriff  _
mit SVERWEIS gesucht wird. Außerdem habe ich das Programm so ergänzt, dass doppelte Sätze vermieden werden.
Es sieht jetzt 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 rngTransTab As Range
Dim sätzeGleich As Boolean
Dim spalte As Long
Dim transTab As Variant
Dim übersLeistung As Variant ' aktLeistung wird mit Hilfe der
' Übersetzungstabelle Projektpalnung!W:X
' in übersLeistung übersetzt
Dim wsH As Worksheet  ' Hilfsblatt
Dim wsQ As Worksheet  ' Quelle (Blatt "Obst")
Dim wsZ As Worksheet  ' Ziel (Blatt "Projektplanung")
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)
übersLeistung = Übersetzung(aktLeistung, transTab)
If IsError(übersLeistung) Then
MsgBox Prompt:="Der Begriff """ & aktLeistung & """" & vbNewLine & _
"(entstanden aus """ & wsQ.Cells(zeileQ, 2) & _
""" Zeile " & zeileQ & ")" & vbNewLine & _
"steht nicht in der " & _
"Übersetzungstabelle """ & wsZ.Name & "!" & _
rngTransTab.Address(False, False) & """" & _
vbNewLine & vbNewLine & _
"Das Programm wird beendet!", _
Buttons:=vbCritical
Exit Sub
End If
wsH.Cells(zeileH, "C") = übersLeistung
wsQ.Cells(zeileQ, "B").Resize(, 9).Copy Destination:=wsH.Cells(zeileH, "D")
End If
End If
Next zeileQ
letzteZeileH = zeileH
If letzteZeileH > 0 Then
' 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
End If
' Doppelte Sätze aus dem Hilfsblatt entfernen
For zeileH = letzteZeileH To 2 Step -1
sätzeGleich = True
For spalte = 3 To 12
If wsH.Cells(zeileH, spalte)  wsH.Cells(zeileH - 1, spalte) Then
sätzeGleich = False
Exit For
End If
Next spalte
If sätzeGleich Then
wsH.Rows(zeileH).Delete
End If
Next zeileH
' 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
Function Übersetzung(Leistung As String, _
Tabelle As Variant) As Variant
On Error GoTo Fehlerbehandlung
Übersetzung = WorksheetFunction.VLookup(Leistung, Tabelle, 2, 0)
Exit Function
Fehlerbehandlung:
Übersetzung = CVErr(xlErrNA)
End Function
https://www.herber.de/bbs/user/132957.xlsm
Viele Grüße
Dieter