Hallo Sven,

hier scheints irgendwie noch nicht weitergegangen zu sein. Wie ich bereits schrieb, benötigtst du dafür ein Workbook, wo du alle Daten sammelst. Angenommen das Wb heißt "Lieferantenbewertung.xlsm" und hat zwei Tabellenblätter "Einzeldaten" und "Gesamtdaten". Sobald du nun auf dem Blatt "Einzeldaten" eine Firma auswählst, die es auf dem Blatt "Gesamtdaten" noch nicht gibt, wird diese dort zusammen mit den einzelnen Bewertungskategorien angelegt. Ist sie jedoch bereits vorhanden müssen die erste und letzte Zeile der Firma ermittelt und die Daten aus den benachbarten Zellen geholt werden.

Grundsätzlich ist es immer besser, bei Fragen ein Beispielworkbook anstelle von Bildern hochzuladen. Kein Helfer hat wirklich Lust und Zeit, erst irgendwelche Beispieldaten nachzubauen. Ich habs trotzdem mal gemacht. War ja diesmal nicht viel. Leider zeigen deine Screenshots aber keinerlei Zeilen und Spaltenköpfe. Ich kann daher nur mutmaßen. Angenommen die Firma wird in B3 eingegeben und die Eingabezellen der Bewertungstabelle erstrecken sich von E8:K19 dann könnte der Code im Tabellenmodul "Einzeldaten" in etwa so lauten:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim First As Range, Last As Range, Gesamt As Worksheet
  
  Set Gesamt = Sheets("Gesamtdaten")
  Set First = Gesamt.Columns(1).Find(Range("B3").Value, SearchDirection:=xlNext)
  Set Last = Gesamt.Columns(1).Find(Range("B3").Value, SearchDirection:=xlPrevious)
  
  If Target.Address(False, False) = "B3" Then 'Wenn Firma wechselt
    If First Is Nothing Then
      Range("E8:K19").ClearContents
      Set First = Gesamt.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
      Set Last = First.Offset(19 - 8, 0)
      Gesamt.Range(First, Last).Value = Target.Value
      Gesamt.Range(First, Last).Offset(0, 1).Resize(, 2).Value = Range("C8:D19").Value
    Else
      Range("E8:K19").Value = Gesamt.Range(First, Last).Offset(0, 3).Resize(, 7).Value
    End If
  ElseIf Not Intersect(Target, Range("E8:K19")) Is Nothing Then
    If Not First Is Nothing And Not Last Is Nothing Then
      Gesamt.Range(First, Last).Offset(0, 3).Resize(, 7).Value = Range("E8:K19").Value
    End If
  End If
End Sub

Für das exportierte Speichern der Bewertung einer einzelnen Firma brauchst du dann nur noch einen Button, dem du den folgenden Code (z.B. im gleichen oder in einem allgemeinen Modul) hinterlegst:

Sub Firma_Extrahieren()
  Dim Pfad As String, Dateiname As String
  Pfad = ThisWorkbook.Path
  Dateiname = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & " (" & Range("B3").Value & ")"
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Sheets("Einzeldaten").Copy
  ActiveWorkbook.SaveAs Pfad & "\" & Dateiname, FileFormat:=xlOpenXMLWorkbook
  ActiveWorkbook.Close
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Die Gesamt-Datei muss zuvor mindestens einmal gespeichert sein.

Möchtest du die Bewertung einer Firma nicht nur speichern, sondern auch gleich an eine Email anhängen und rausschicken? Dazu gibt es mehr als genügend Beispiele im Netz und auch hier im Forum. Deshalb gehe ich darauf nicht näher ein.

Gruß Mr. K.