使用VBA有條件地更新公式

Question

我想使用VBA函數根據兩個條件將公式插入到單元格中。

條件是（1）說明中必須有某些內容（電子表格上的D列），並且（2）我要粘貼代碼的單元格必須為空白。

我看到的最好的方法是使用循環，但是我不知道如何更新公式中的引用以考慮新位置。

下面的代碼有效，但是它不會首先檢查單元格是否為空。

Range("B8").Formula = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,2,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,2,FALSE)))"
Range("B8").Select
Selection.AutoFill Destination:=Range("B8:B" & Total), Type:=x1filldefault
'Adds the above formula into the range B8 to B(the last cell in use)
Range("C8").Formula = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,3,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,3,FALSE)))"
Range("C8").Select
Selection.AutoFill Destination:=Range("C8:C" & Total), Type:=x1filldefault
'Adds the above formula into the range C8 to C(the last cell in use)
Range("E8").Formula = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,4,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,4,FALSE)))"
Range("E8").Select
Selection.AutoFill Destination:=Range("E8:E" & Total), Type:=x1filldefault
'Adds the above formula into the range E8 to E(the last cell in use)
Range("J8").Formula = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,9,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,9,FALSE)))"
Range("J8").Select
Selection.AutoFill Destination:=Range("J8:J" & Total), Type:=x1filldefault
'Adds the above formula into the range J8 to J(the last cell in use)
Range("A8").Formula = "=If(B8="""","""",Row(A8))"
Range("A8").Select

Answer 1

未經測試，但這應該做您想要的。

循環中：

For i = 8 to Total
    If cells(i, 4) <> "" Then
        AddFormulaIfNotBlank cells(i, 2), _            
        "=IF(D<r>="""","""",IF(ISERROR(VLOOKUP(Trim(D<r>),Sheet3!$B$8:$M$7500,2,FALSE))" _
        & ","""",VLOOKUP(Trim(D<r>),Sheet3!$B$8:$M$7500,2,FALSE)))"

        'add rest of formulas here....

    Next i
Next i

輔助子：僅填充空單元格，並調整當前行的公式

Sub AddFormulaIfNotBlank(c As Range, f As String)
    If Len(c.value)=0 Then
        c.formula = Replace(f, "<r>", c.Row)
    End If
End sub

Answer 2

我已經對此進行了簡短的測試。 它假定當前選定的單元格在您要開始執行此過程之前要移至該列的頂部。 也沒有任何錯誤處理

Sub CopyFormulas()

Dim xlRange As Range
Dim xlCell As Range
Dim xlAddress As String


    xlAddress = ActiveCell.Address & ":$" & Mid(ActiveCell.Address, 2, InStr(1, ActiveCell.Address, "$")) & Mid(Cells.SpecialCells(xlCellTypeLastCell).Address, InStrRev(Cells.SpecialCells(xlCellTypeLastCell).Address, "$"), Len(Cells.SpecialCells(xlCellTypeLastCell).Address))
    Set xlRange = Range(ActiveCell, xlAddress)
    For Each xlCell In xlRange
        xlAddress = "D" & Mid(xlCell.Address, InStrRev(xlCell.Address, "$"), Len(xlCell.Address))
        If xlCell.Value = "" And Range(xlAddress).Value <> "" Then
            xlCell.Value = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,2,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,2,FALSE)))"
        End If
    Next xlCell
End Sub