Hallo zusammen,

ich brauche eure Hilfe. Eine KI hat dieses Makro für mich geschrieben und es funktioniert grundsätzlich sehr gut. Es gibt nur einen Fehler bei der Behandlung der Hierarchie:

Die oberste Hierarchie (z. B. 1-4-1) soll in Spalte O gesucht werden.

Wird der Begriff gefunden → der entsprechende Wert aus Tabelle1 (Spalte D) soll in IFW Art eingetragen werden.

Wird der Begriff nicht gefunden → in IFW Art soll "Nicht gefunden" stehen.

Untergeordnete Hierarchien (z. B. 1-4-1-1, 1-4-1-2) sollen immer leer bleiben.

Aktuell funktioniert das Makro soweit, aber wenn eine oberste Hierarchie nicht gefunden wird, wird der Fehler fälschlicherweise auf die untergeordneten Hierarchien übertragen.

Ziel:

Oberste Hierarchie, gefunden → IFW Art aus Tabelle1 übernehmen

Oberste Hierarchie, nicht gefunden → "Nicht gefunden"

Untergeordnete Hierarchie → immer leer

Danke für eure Unterstützung!





Sub GelbeZeilenMitFormelGesamtKG()
Dim wsQuelle As Worksheet
Dim wsZiel As Worksheet
Dim wsSuche As Worksheet
Dim letzteZeile As Long
Dim letzteSpalte As Long
Dim zielZeile As Long
Dim i As Long
Dim gelbFarbe As Long
Dim j As Long
Dim spalteGesamtKG As Long
Dim spalteIFW As Long
Dim suchWert As String
Dim gefFund As Range
Dim bindestriche As Long
Dim maxBreite As Double

' Aktives Tabellenblatt als Quelle
Set wsQuelle = ActiveSheet

' Suchblatt festlegen
On Error Resume Next
Set wsSuche = Worksheets("Tabelle1")
On Error GoTo 0
If wsSuche Is Nothing Then
MsgBox "Das Tabellenblatt 'Tabelle1' wurde nicht gefunden!", vbCritical
Exit Sub
End If

' Falls Zielblatt schon existiert → löschen
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Gelbe Zeilen").Delete
Application.DisplayAlerts = True
On Error GoTo 0

' Neues Tabellenblatt erstellen
Set wsZiel = Worksheets.Add
wsZiel.Name = "Gelbe Zeilen"

' Gelb-Farbcode (Excel Standardgelb)
gelbFarbe = RGB(255, 255, 0)

' Letzte benutzte Zeile und Spalte im Quellblatt finden
letzteZeile = wsQuelle.Cells(wsQuelle.Rows.Count, "A").End(xlUp).Row
letzteSpalte = wsQuelle.Cells(1, wsQuelle.Columns.Count).End(xlToLeft).Column

' Überschrift kopieren
wsQuelle.Rows(1).Copy Destination:=wsZiel.Rows(1)

' Neue Spalten hinzufügen
spalteGesamtKG = letzteSpalte + 1
spalteIFW = letzteSpalte + 2
wsZiel.Cells(1, spalteGesamtKG).Value = "Gesamt KG"
wsZiel.Cells(1, spalteIFW).Value = "IFW Art."

' Format der neuen Überschriften
For j = spalteGesamtKG To spalteIFW
With wsZiel.Cells(1, j)
.Font.Name = wsZiel.Cells(1, 1).Font.Name
.Font.Size = wsZiel.Cells(1, 1).Font.Size
.Font.Bold = True
.Interior.ColorIndex = xlNone
.HorizontalAlignment = wsZiel.Cells(1, 1).HorizontalAlignment
.VerticalAlignment = wsZiel.Cells(1, 1).VerticalAlignment
End With
Next j

' Rahmen für Überschrift
wsZiel.Range(wsZiel.Cells(1, 1), wsZiel.Cells(1, spalteIFW)).Borders.LineStyle = xlContinuous

' Startzeile im Zielblatt
zielZeile = 2

' Gelbe Zeilen kopieren
For i = 2 To letzteZeile
If wsQuelle.Rows(i).Interior.Color = gelbFarbe Then
wsQuelle.Rows(i).Copy Destination:=wsZiel.Rows(zielZeile)
wsZiel.Range(wsZiel.Cells(zielZeile, 1), wsZiel.Cells(zielZeile, spalteIFW)).Borders.LineStyle = xlContinuous
wsZiel.Rows(zielZeile).Interior.ColorIndex = xlNone

' Formel setzen (Gesamt KG = J * U)
wsZiel.Cells(zielZeile, spalteGesamtKG).Formula = "=J" & zielZeile & "*U" & zielZeile

' IFW Art. nur für oberste Hierarchie
suchWert = Trim(wsZiel.Cells(zielZeile, "A").Value) ' Hierarchie aus Spalte A
bindestriche = Len(suchWert) - Len(Replace(suchWert, "-", ""))

' Oberste Ebene: z.B. 3 Bindestriche (1-1-1-1)
If bindestriche = 3 Then
If Trim(wsZiel.Cells(zielZeile, "O").Value) > "" Then
Set gefFund = wsSuche.Columns("K").Find(What:=Trim(wsZiel.Cells(zielZeile, "O").Value), _
LookIn:=xlValues, LookAt:=xlWhole)
If Not gefFund Is Nothing Then
wsZiel.Cells(zielZeile, spalteIFW).Value = wsSuche.Cells(gefFund.Row, "D").Value
Else
' Nur oberste Hierarchie bekommt "Nicht gefunden"
wsZiel.Cells(zielZeile, spalteIFW).Value = "Nicht gefunden"
End If
Else
wsZiel.Cells(zielZeile, spalteIFW).Value = "" ' Falls O leer
End If
Else
' Untergeordnete Ebenen bleiben immer leer
wsZiel.Cells(zielZeile, spalteIFW).Value = ""
End If

zielZeile = zielZeile + 1
End If
Next i

' Kein Zeilenumbruch + AutoFit
With wsZiel.Cells
.WrapText = False
End With
wsZiel.Columns.AutoFit

' Spalten H und S maximal so breit wie Spalte O
maxBreite = wsZiel.Columns("O").ColumnWidth
If wsZiel.Columns("H").ColumnWidth > maxBreite Then wsZiel.Columns("H").ColumnWidth = maxBreite
If wsZiel.Columns("S").ColumnWidth > maxBreite Then wsZiel.Columns("S").ColumnWidth = maxBreite

' Spalten ausblenden (wenn vorhanden)
On Error Resume Next
wsZiel.Columns("B").Hidden = True
wsZiel.Columns("I").Hidden = True
If wsZiel.Columns.Count >= 39 Then wsZiel.Columns("V:AM").Hidden = True
On Error GoTo 0

' Neues Blatt aktivieren
wsZiel.Activate

' Abschlussmeldung
MsgBox "Fertig! Gelbe Zeilen wurden kopiert (ohne Farbe)." & vbCrLf & _
"Spalten B, I und V:AM wurden ausgeblendet." & vbCrLf & _
"IFW Art.-Werte aus Tabelle1 (Spalte D) wurden ergänzt (nur oberste Hierarchie)." & vbCrLf & _
"Spalten H und S wurden auf maximale Breite von Spalte O angepasst.", vbInformation
End Sub