vba案例不插入公式

我一直在这个代码上工作了一段时间，似乎无法得到它的工作。 我正在尝试在列AP中插入一个公式基于D列的同一行中的单元格的值。代码循环但不会将公式列AP列的单元格中。

Sub DTCNFScontract() Sheets("Cognos Data").Select Range("A2").Select Dim LastRow As Long LastRow = ActiveSheet.UsedRange.Rows.Count Dim rCell As Range Dim Rng As Range Set Rng = Range("D2:D" & LastRow) 'Insert Hash Calculation Based On SO Type and VLOOKUP Sheets("Cognos Data").Select For Each rCell In Rng.Cells Select Case Rng.Select Case rCell = "Z006" Rng(, "AP").Formula = "=IF(AND(VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-41]:C[-40],2,0)<3,VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-41]:C[-39],3,0)<50),""Hash"","""")" Case rCell = "Z002" Rng(, "AP").Formula = "=IF(AND(VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-37]:C[-36],2,0)<3,VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-37]:C[-35],3,0)<50),""Hash"","""")" Case rCell = "Z013" Rng(, "AP").Formula = "=IF(AND(VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-37]:C[-36],2,0)<3,VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-37]:C[-35],3,0)<50),""Hash"","""")" Case Else Rng(, "AP").Formula = """" End Select Next rCell 'Copy Calculations and Paste As Values Columns("AP:AP").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Sheets("Cognos Data").Select Range("A2").Select End Sub 

Answer 1

如果你使用D作为AP的标准，你的Select Case应该以rCell.Value为参考点。 看下面的代码。

 Sub DTCNFScontract() Dim CognosSht As Worksheet Dim LastRow As Long Dim rCell As Range Dim Rng As Range Set CognosSht = Sheets("Cognos Data") With CognosSht LastRow = CognosSht.UsedRange.Rows.Count Set Rng = .Range("D2:D" & LastRow) 'Turn off calculations first so that no calculations are triggered while inserting formula. 'That will add too much execution time. With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With 'Insert Hash Calculation Based On SO Type and VLOOKUP For Each rCell In Rng Select Case Trim(rCell.Value) 'NOTE: VLOOKUP FORMULAS ARE INCOMPLETE! Case "Z006" .Range("AP" & rCell.Row).Formula = "=IF(AND(VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-41]:C[-40],2,0)<3,VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-41]:C[-39],3,0)<50),""Hash"","""")" Case "Z002" .Range("AP" & rCell.Row).Formula = "=IF(AND(VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-37]:C[-36],2,0)<3,VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-37]:C[-35],3,0)<50),""Hash"","""")" Case "Z013" .Range("AP" & rCell.Row).Formula = "=IF(AND(VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-37]:C[-36],2,0)<3,VLOOKUP('Cognos Data'!C[-21],'AP Hash Build Pivot'!C[-37]:C[-35],3,0)<50),""Hash"","""")" Case Else .Range("AP" & rCell.Row).Formula = """" End Select Next 'Calculate everything after inserting formulas. 'An alternative is to use `Evaluate` instead while inserting formulas 'but that can be slower. With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With 'Copy Calculations and Paste As Values With .Columns("AP:AP") .Copy .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End With Application.CutCopyMode = False .Range("A2").Select End With End Sub 

让我们知道如果上述作品。

Answer 2

你好你的代码是接近完美的，在这个Rng(, "AP").Formula因为你没有给行索引，你的代码复制公式在同一个单元格（你的范围内的第一个单元格），所以公式正在被取代每次在遍历单元格时，都不会将公式放入不同的单元格中。 我修改了你的代码，插入行索引。 将工作表名称和公式更改为您的依据。

 Sub DTCNFScontract() Sheets("sheet1").Select Range("A2").Select Dim LastRow As Long LastRow = ActiveSheet.UsedRange.Rows.Count Dim rCell As Range Dim Rng As Range Set Rng = Range("D1:D10") x = 1 'Insert Hash Calculation Based On SO Type and VLOOKUP Sheets("sheet1").Select For Each rCell In Rng.Cells Select Case Rng.Select Case rCell = "Z006" Rng(x, "E").Formula = "=A3*6" Case rCell = "Z002" Rng(x, "E").Formula = "=A3*2" Case rCell = "Z013" Rng(x, "E").Formula = "=A3*13" Case Else Rng(x, "E").Formula = """" End Select x = x + 1 Next rCell 'Copy Calculations and Paste As Values Columns("E:E").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Sheets("sheet1").Select Range("A2").Select End Sub