[Excel] Mit VBA Code nur die Formel kopieren

[josef24]

Guten Tag zusammen.
Ich möchte aus der Tabelle1, Spalte "D2" die Formel nach Tabelle2 Spalte D2 beginnend bis zur letzten Spalte kopieren. Ich finde nirgends den richtigen Codetext hierfür.
Freue mich über eure Unterstützung und bedanke mich für eure Unterstützung. Gruß Josef

Option Explicit
Private Sub kopiere_Formel_Wert() 
Dim letzte As Long
With Worksheets("Tabelle1")
 .Range("D2").Copy

 Worksheets("Tabelle2").Range("D2:D100").PasteSpecial xlPasteValues
 .Range("C2").Copy

 Dim quelle_letzte As Long
 Worksheets("Tabelle2").Range("C2:C100").PasteSpecial (xlPasteFormats)
 Application.CutCopyMode = False
End With
    letzte = 0
    quelle_letzte = 0

End Sub

 

[Yaslaw]

Denn muss man auch nicht finden, den muss man programmieren.
Am einfachsten über R1C1-Formel

Private Sub kopiere_Formel_Wert()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim formulaR1C1 As String
    Dim rowNr As Long
    
    Set ws1 = ActiveWorkbook.Sheets("Sheet1")
    Set ws2 = ActiveWorkbook.Sheets("Sheet2")

    formulaR1C1 = ws1.Range("D2").FormulaR1C1Local
    
    For rowNr = 2 To xlsGetLastRow(ws2)
        ws2.Range("D" & rowNr).FormulaR1C1Local = formulaR1C1
    Next rowNr
End Sub


'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet   Das Worksheetobjekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.Rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function

 

[josef24]

Danke für die schnelle Antwort. Funktioniert natürlich prima. Hatte mir eingebildet dass ich das so einfach auf weitere Spalten anwenden könnte, s.B. ist mir aber leider nicht gelungen. Was ich noch erreichen möchte ist, für die Spalte "C" und "H" die Formatierung ebenfalls in Tabelle2 zu kopieren. Vielleicht ist nochmal Unterstützung möglich? Gruß Josef

Private Sub kopiere_Formel_Wert()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim formulaR1C1 As String
    Dim rowNr As Long
    
    Set ws1 = ActiveWorkbook.Sheets("Tabelle1")
    Set ws2 = ActiveWorkbook.Sheets("Tabelle2")

     formulaR1C1 = ws1.Range("D2").FormulaR1C1Local
'     formulaR1C1 = ws1.Range("E2").FormulaR1C1Local
'     formulaR1C1 = ws1.Range("F2").FormulaR1C1Local
    
    
    For rowNr = 2 To xlsGetLastRow(ws2)
        ws2.Range("D" & rowNr).FormulaR1C1Local = formulaR1C1
'        ws2.Range("E" & rowNr).FormulaR1C1Local = formulaR1C1
'        ws2.Range("F" & rowNr).FormulaR1C1Local = formulaR1C1
    Next rowNr
End Sub

 

[Yaslaw]

Wie hast du es mit der Formatierung denn versucht?

 

[josef24]

Habe meine Idee mal eingebracht (in meinem Beispiel oben), bin mir aber nicht sicher, ob das dann korrekt funktioniert???. Hätte wahrscheinlich hier auch das Problem, wenn noch eine Spalte dazu käme.
Gruß Josef

Private Sub kopiere_Formel_Wert()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim formulaR1C1 As String
    Dim rowNr As Long
    
    Set ws1 = ActiveWorkbook.Sheets("Tabelle1")
    Set ws2 = ActiveWorkbook.Sheets("Tabelle2")

     formulaR1C1 = ws1.Range("D2").FormulaR1C1Local
'     formulaR1C1 = ws1.Range("E2").FormulaR1C1Local
'     formulaR1C1 = ws1.Range("F2").FormulaR1C1Local
    
    
    For rowNr = 2 To xlsGetLastRow(ws2)
        ws2.Range("D" & rowNr).FormulaR1C1Local = formulaR1C1
'        ws2.Range("E" & rowNr).FormulaR1C1Local = formulaR1C1
'        ws2.Range("F" & rowNr).FormulaR1C1Local = formulaR1C1
    Next rowNr
         With Worksheets("Tabelle1")
         .Range("C2,H2").Copy
         Dim quelle_letzte As Long
         Worksheets("Tabelle2").Range("C2:C100", "H2:H100").PasteSpecial (xlPasteFormats)
         Application.CutCopyMode = False
        End With
End Sub

 

[Yaslaw]

Ach, Formel, nicht wie von dir geschrieben Formatierung!
Du kannst natürlich formulaR1C1Local drei mal überschreiben und nachher nur mit dem letzten arbeiten. Bringt aber nicht viel.
Entweder deklarierst du 3 Variablen oder liest jedes mal die Werte neu aus.

Private Sub kopiere_Formel_Wert()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim formulaD As String, formulaE As String, formulaF As String
    Dim rowNr As Long
    
    Set ws1 = ActiveWorkbook.Sheets("Tabelle1")
    Set ws2 = ActiveWorkbook.Sheets("Tabelle2")

     formulaD = ws1.Range("D2").FormulaR1C1Local
     formulaE = ws1.Range("E2").FormulaR1C1Local
     formulaF = ws1.Range("F2").FormulaR1C1Local
    
    
    For rowNr = 2 To xlsGetLastRow(ws2)
        ws2.Range("D" & rowNr).FormulaR1C1Local = formulaD
        ws2.Range("E" & rowNr).FormulaR1C1Local = formulaE
        ws2.Range("F" & rowNr).FormulaR1C1Local = formulaF
    Next rowNr
End Sub

 

[josef24]

Vielen Dank für deine Lösung, mit den Formeln kopieren ist perfekt. Mit der Formatierung das konnte ich selbst lösen.
Gruß Josef

 

[josef24]

Hallo zusammen. Muss doch noch mal auf das Thema zurückkommen. Und zwar möchte ich wenn in Spalte "U" eine Eintrag(SZ) steht, in Spalte "V" dieses +++++++ einfügen lassen. Der Kode gibt mir "FALSCH" oder "#NAME?" zurück. Das einspeisen will mir nicht gelingen. Darf ich nochmal um Unterstützung bitten? Danke und Gruß Josef

Range("V2").FormulaLocal = "=WENN($U2=""SZ"";Formula(V2;""+""))"   ' Wenn Bedingung erfüllt dann ++++++++ einfügen!
Range("V2:V" & irow).FillDown

 

[Yaslaw]

Falsche Klammersezung

Range("V2").FormulaLocal = "=WENN($U2=""SZ"";Formula(V2) ; ""+"")"

 

[josef24]

Danke, so gehts leider auch nicht. Wenn das SZ gesetzt ist, kommt als Ergebnis #NAME? Hier müste aber das ++++ stehen. Und wenn kein Eintrag in Spalte "U", hätte ich gerne auch ein leeres Datenfeld, also keine ++++. Wie müsste ich den Kode dafür verändern? Geht vielleicht noch eine Ergänzung dahin gehend? Das Ergebnis wie es jetzt aussieht. Gruß Josef

Bemerkung    Btrg 20€    Unterschrift
 SZ               #NAME?    #NAME?
 SZ               #NAME?    #NAME?
 leer             +++++    ++++++++++++++++++++++
 leer             +++++    ++++++++++++++++++++++
 leer             +++++    ++++++++++++++++++++++