Guten Morgen,

ich versuche für die Kolleginnen und Kollegen ein Tool zu entwickeln, das auf elegante Art und Weise nach Eingabe in einer Maske (Blattname "Insert new deal") die Daten bei Click eines Buttons rüberkopiert in ein anderes Arbeitsblatt namens "Deal list". Hier jeweils in die nächste freie Zeile, also in eine Zeile die entsprechend noch nicht befüllt ist mit Daten (von unten nach oben). Das macht er mit allen Daten auch sehr elegant bislang, nur nicht die Informationen in den Feldern D10, D11 und D12 aus Insert New Deal in bspw D49, E49, F49 (die Zeile ist ja bekanntlich variabel je nachdem ob sie leer ist oder nicht), denn hier sind Bilder / Pictures in den Zellen reinkopiert. Die Excel Funktion "Insert Picture placed in cell" wurde hier verwendet. Nun kann er glaube ich Pictures nicht als Werte kopieren und gibt mir bei Click gem. des Codes unten den "#VALUE!" Fehler zurück. 

Wie muss man den Code anpassen, dass es klappt? 

++++++++++++++++++

Sub CommandButton1_Click()

    ' Define the cells to copy from "Insert new deal"
    Dim sourceCells As Variant
    sourceCells = Array("D8", "D9", "D10", "D11", "D12", "D13", "D14", "D18", "D19", "D20", "D28", "D36", "D37", "D38", "D39", "D40", "D41", "D42", "D43", "D44", "D45", "D46", "D47", "D48", "D49")
    
    ' Define the destination columns in "Deal list"
    Dim destinationColumns As Variant
    destinationColumns = Array("B", "C", "D", "F", "G", "G", "H", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC")
    
    ' Find the next row in "Deal list" where column B is blank above the last row with a value in column B
    Dim lastRow As Long
    lastRow = Sheets("Deal list").Cells(Rows.Count, 2).End(xlUp).Row + 1
    
    ' Loop through each cell and copy-paste as values
    Dim i As Integer
    For i = LBound(sourceCells) To UBound(sourceCells)
        Sheets("Deal list").Cells(lastRow, destinationColumns(i)).Value = Sheets("Insert new deal").Range(sourceCells(i)).Value
    Next i
    
    ' Clear the clipboard
    Application.CutCopyMode = False
    
    ' Delete the data from the source cells in "Insert new deal" except D20 and D28
    For i = LBound(sourceCells) To UBound(sourceCells)
        If sourceCells(i) <> "D20" And sourceCells(i) <> "D28" Then
            Sheets("Insert new deal").Range(sourceCells(i)).ClearContents
        End If
    Next i
    
    ' Additionally delete specific cells in "Insert new deal"
    Dim deleteCells As Variant
    deleteCells = Array("D21", "D22", "D23", "D24", "D25", "D26", "D27", "D29", "D30", "D31", "D32", "D33", "D34", "D35")
    
    For i = LBound(deleteCells) To UBound(deleteCells)
        Sheets("Insert new deal").Range(deleteCells(i)).ClearContents
    Next i

End Sub