105 Aufrufe
Gefragt in Tabellenkalkulation von

Hallo zusammen,

ich habe folgendes Problem. Ich habe eine Liste mit Datensätzen (Artikelnummern und Bilddaten). Ich habe allerdings mehrer Zeilen mit dem selben Artikel und jeweils einem dazugehörigen Bild. Ich benötige nun eine Lösung um nur noch 1 Zeile zu haben mit mehreren Spalten dahinter in denen alle Bilddaten jeweils in einer Zelle stehen.

Siehe Bild:

2 Antworten

0 Punkte
Beantwortet von

Hallo KoMo,

es ist nur ein Versuch, aber vielleicht hilft dir dieses Makro weiter. Vorraussetzungen sind eine sortierte Liste (Artikel 1 darf nach Artikel 2 nicht mehr vorkommen), Die Bilder stehen wirklich in Spalte B und dürfen mit der oberen linken ecke nicht über oberen Zellrand kommen, sonst werden sie dem vorherigen Artikel zugeordnet. Die obere linke Ecke des Bildes ist also entscheidend für die korrekte Zuordnung zum Artikel.  Versuchs einfach mal.

Sub BilderOrdnen()
  
  Set tbl1 = Sheets("Tabelle1") 'Quelldaten
  Set tbl2 = Sheets("Tabelle2") 'Zieldaten
  
  For Each p In tbl1.Pictures
    altartikel = artikel
    artikel = p.TopLeftCell.Offset(0, -1)
    If artikel <> altartikel Then counter = 0
    p.Copy
    Set c = tbl2.Range("A:A").Find(artikel)
    counter = counter + 1
    If c Is Nothing Then
      Set c = tbl2.Cells(Columns(1).Cells.Count, 1).End(xlUp).Offset(1, 0)
      counter = 1
    End If
    c.Value = artikel
    tbl2.Activate
    c.Offset(0, counter).Select
    tbl2.Paste
  Next p
  
End Sub

Gruß Mr. K.

0 Punkte
Beantwortet von

Hallo KoMo,

Nimm mal lieber diesen Code. Damit werden auch Artikel aufgelistet, bei denen kein Bild hinterlegt ist. Außerdem werden Zeilen- und Spaltenbreite des Zielblattes an die Bildverhältnisse angepasst.

Sub BilderOrdnen()
  
  Dim oldcell As Range
  
  Set tbl1 = Sheets("Tabelle1") 'Quelldaten
  Set tbl2 = Sheets("Tabelle3") 'Zieldaten
  
  For Each p In tbl1.Pictures
    altartikel = artikel
    artikel = p.TopLeftCell.Offset(0, -1)
    If artikel <> altartikel Then
      counter = 0
      If oldcell Is Nothing Then Set oldcell = p.TopLeftCell.Offset(0, -1)
      If p.TopLeftCell.Offset(0, -1).Row > oldcell.Row + 1 Then
        For i = oldcell.Row + 1 To p.TopLeftCell.Offset(0, -1).Row - 1
          tbl2.Cells(Columns(1).Cells.Count, 1).End(xlUp).Offset(1, 0) = tbl1.Cells(i, 1)
        Next i
      End If
    End If
    
    Set oldcell = p.TopLeftCell.Offset(0, -1)
    
    p.Copy
    Set c = tbl2.Range("A:A").Find(artikel)
    counter = counter + 1
    If c Is Nothing Then
      Set c = tbl2.Cells(Columns(1).Cells.Count, 1).End(xlUp).Offset(1, 0)
      counter = 1
    End If
    c.Value = artikel
    tbl2.Activate
    If Rows(c.Row).Height <= p.Height Then Rows(c.Row).RowHeight = p.Height
    c.Offset(0, counter).Select
    If Columns(c.Offset(0, counter).column).Width < p.Width Then
      Columns(c.Offset(0, counter).column).ColumnWidth = GetColumnWidth(p.Width)
    End If
    tbl2.Paste
    Selection.Top = c.Top
    Selection.Left = c.Offset(0, counter).Left
  Next p
  
End Sub
Function GetColumnWidth(Width As Single)
     GetColumnWidth = Columns(1).ColumnWidth / Columns(1).Width * Width
End Function

Gruß Mr. K.

...