excel - VBA粘贴过滤列中的公式

Question

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

Answer 1

这是可以完成的，但将公式带到另一个工作表会出现问题。可以循环选取公式，但需要修改单元格地址以反射(reflect)原始工作表名称。如果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

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