使用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