使用 VBA 將 Excel 公式寫入單元格

Question

就像我的標題中已經寫的一樣，我試圖覆蓋錯誤的 excel 公式。 但它並沒有真正起作用。 我將單元格中的公式復制到代碼中並放置了一些雙引號以使其工作。 已經讀過，我必須輸入兩次“才能在公式中輸入一個”。 由於公司合規性，我不知道到底發生了什么，但代碼應該這樣做。

想象一下，單元格中有 180 個組件具有相同的 18 個 function。 通過刪除一些組件，我丟失了參考，而不是再次編寫每個公式，我嘗試使用 vba 來執行此操作。 希望您能夠幫助我。

Sub nachtrag()

Dim i As Integer
Dim j As Integer
Dim Start As Integer
    Start = 4
Dim Bezug As Integer

For i = 0 To 179
    Bezug = Worksheets("QK-Daten").Range("R" & ((i * 18) + 18) + Start).Value
    For j = 1 To 17
    Worksheets("QK-Daten").Range("Z" & j + (i * 18) + Start).Value = "=WENN(R" & Bezug & "="""";"""";SVERWEIS(R" & Bezug & ";'QK-Tabelle'!$B$3:$C$123;2;FALSCH))*(R" & j + (i * 18) + Start & "/R" & Bezug & ")+((N" & j + (i * 18) + Start & "+O" & j + (i * 18) + Start & ")*0,3+(P" & j + (i * 18) + Start & "+Q" & j + (i * 18) + Start & ")*0,1)"
    Next j
    Worksheets("QK-Daten").Range("z" & ((i * 18) + 18) + Start).Copy
    Worksheets("QK-Daten").Range("z" & ((i * 18) + 18) + Start).PasteSpecial Paste:=xlValues
Next i

End Sub

Answer 1

嘗試在字符串中使用占位符編寫公式，然后使用Replace()替換值。

Option Explicit

Sub nachtrag()

    Dim ws As Worksheet, cell As Range, s As String
    Dim Bezug As Long, Start As Long
    Dim i As Long, j As Long, r As Long
    
    ' formula
    Const F = "=IF(R<bezug>="""";"""";VLOOKUP(R<bezug>;'QK-Tabelle'!$B$3:$C$123;2;FALSE))" & _
              "*(R<r>/R<bezug>)+((N<r>+O<r>)*0,3+(P<r>+Q<r>)*0,1)"
    
    Start = 4
    Set ws = Worksheets("QK-Daten")
    With ws
        Set cell = .Range("R" & Start)
        For i = 0 To 179
            Bezug = cell.Offset(18).Row 'Value
            For j = 1 To 17
                r = j + (i * 18) + Start
                s = Replace(F, "<bezug>", Bezug)
                s = Replace(s, "<r>", r)
                cell.Offset(j, 8).Formula = s 'Z
            Next j
            
            ' not sure what this is doing
            ' .Range("z" & ((i * 18) + 18) + Start).Copy
            ' .Range("z" & ((i * 18) + 18) + Start).PasteSpecial Paste:=xlValues
            cell.Offset(18, 8).Value = cell.Offset(18, 8).Value
            
            ' next component
            Set cell = cell.Offset(18)
           
        Next i
    End With
    
    MsgBox "Done", vbInformation
End Sub