过滤列中的 VBA 粘贴公式

Posted 2023-02-19

【中文标题】过滤列中的 VBA 粘贴公式

【英文标题】：VBA paste formulas from filtered column

【发布时间】：2015-08-18 19:31:16

【问题描述】：

Excel(VBA) 中是否可以从 1 个语句中的过滤列中复制/粘贴公式？这有效：

Sheets(1).Range("A2:C" & LastRow).Copy
Sheets(2).Range("A2:C" & Range("D" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteFormulas

但这会返回混乱的行（可能是因为列被过滤了）：

Sheets(2).Range("A2:C" & Range("D" & Rows.Count).End(xlUp).Row).Formula = Sheets(1).Range("A2:C" & LastRow).Formula

如果可以在不使用剪贴板的情况下在 1 条语句中执行此操作，有什么想法吗？

编辑

在 Sheet1 中，我将公式添加到 A、B 和 C 列：

With Sheets(1)
    LastRow = .Range("D" & Rows.Count).End(xlUp).Row
    .Range("A5:A" & LastRow).Value = "=D5/$A$3*100"
    .Range("A:AG").AutoFilter Field:=22, Criteria1:=">=1/1/2014", Operator:=xlAnd, Criteria2:="<=12/31/2014"
    .Range("B5:B" & LastRow).SpecialCells(xlCellTypeVisible).Value = "=D" & .UsedRange.Offset(5, 0).SpecialCells(xlCellTypeVisible).Row & "/$B$3*100"
    .Range("A:AG").AutoFilter Field:=22, Criteria1:=">=1/1/2015"
    .Range("C5:C" & LastRow).SpecialCells(xlCellTypeVisible).Value = "=D" & .UsedRange.Offset(5, 0).SpecialCells(xlCellTypeVisible).Row & "/$C$3*100"
    .ShowAllData
End With

因此A列有公式“=Dn/$A$3*100，其中n是行号。B和C公式除以B3和C3单元格值。然后我过滤Sheet1，复制过滤后的行并将它们粘贴到Sheet2

Sheets(1).Range("A4:AG" & LastRow).AutoFilter Field:=7, Criteria1:=name
Sheets(1).Range("A5:C" & LastRow).Copy
Sheets(2).Range("A5:C" & Range("D" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteFormulas

【问题讨论】：

您是否尝试过使用.FormulaLocal 而不是.Formula？还有.FormulaHidden 和.FormulaArray 可能会有所帮助。

我试过了，但没有用，只有在过滤器第一次排除行之前才更正值。无论如何感谢您的建议

也许Enum XlCellType有一些东西可以挖掘，包含：Const xlCellTypeFormulas = -4123 (&HFFFFEFE5) 和Const xlCellTypeVisible = 12

你能添加一个公式示例的图片吗？过滤了哪个工作表？复制面还是粘贴面？请注意.End 将跳过隐藏单元格，这些单元格在您过滤数据后变得相关。您能否还显示LastRow 的来源？我让你的代表超过 10 点，所以你可以发一张照片。

【参考方案1】：

这可以做到，但将公式带到另一个工作表会出现问题。该公式可以在循环中选取，但需要修改单元格地址以反映原始工作表名称。如果应用Application.ConvertFormula method 并将公式转换为严格的xlAbsolute 样式，则可以检查每个$ 以查看以原始工作表名称开头是否合适。您提供的公式（例如 =Dn/$A$3*100）相当简单，解析时应该不会出现任何问题。

Sub Copy_Filtered_Formulas()
    Dim lr As Long, lc As Long, rVIS As Range
    Dim vr As Long, vc As Long, sFRML As String, p As Long
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")

    With ws2
        If Not IsEmpty(.Cells(5, 1)) Then
            With .Range(.Cells(5, 1), .Cells(Rows.Count, 1).End(xlUp))
                .Resize(.Rows.Count, 3).ClearContents
            End With
        End If
    End With

    With ws1
        If .AutoFilterMode Then .AutoFilterMode = False
        lc = .Range("AG:AG").Column
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        With .Cells(4, 1).Resize(lr - 3, lc)
            With .Offset(1, 0).Resize(.Rows.Count - 1, 3)
                .Formula = "=$D5/A$3*100"
            End With
            .AutoFilter field:=7, Criteria1:=0
            With .Offset(1, 0).Resize(.Rows.Count - 1, 3)
                If CBool(Application.Subtotal(103, .Cells)) Then
                    For Each rVIS In Intersect(.SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeFormulas))
                        sFRML = Application.ConvertFormula(rVIS.FormulaR1C1, xlR1C1, xlA1, xlAbsolute, rVIS)
                        p = InStr(1, sFRML, Chr(36))
                        Do While CBool(p)
                            If Asc(Mid(sFRML, p + 1, 1)) >= 65 And _
                              Asc(Mid(sFRML, p + 1, 1)) <= 90 And _
                              Asc(Mid(sFRML, p - 1, 1)) <> 33 And _
                              Asc(Mid(sFRML, p - 1, 1)) <> 58 Then
                                sFRML = Left(sFRML, p - 1) & Chr(39) & .Parent.Name & Chr(39) & Chr(33) & Mid(sFRML, p, 999)
                                p = InStr(p + Len(.Parent.Name) + 5, sFRML, Chr(36))
                            Else
                                p = InStr(p + 3, sFRML, Chr(36))
                            End If
                        Loop
                        With ws2
                            .Cells(Rows.Count, rVIS.Column).End(xlUp).Offset(1, 0).Formula = sFRML
                        End With
                    Next rVIS
                End If
            End With
        End With
    End With
End Sub

当然，如果您从未打算将原始工作表的名称与公式一起传输，那么可以丢弃很多代码。