Question

我在这个网站上找到了下面的代码，一旦我引用了相应的单元格等，它就能完美地工作。但是，我试图修改它以保留公式，但我没有太多运气。非常感谢任何帮助。

Sub test()
    Dim names As New Collection
    Dim ws As Worksheet, ws1 As Worksheet
    Dim wb As Workbook
    Dim lastrow As Long
    Dim cell As Range
    Dim nm As Variant
    Dim res As Range
    Dim rngHeader As Range

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    With ws
        'change "A" to column with "Names"
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

        'change "A" to column with "Names"
        For Each cell In .Range("A2:A" & lastrow)
            On Error Resume Next
            'collect unique names
            names.Add CStr(cell.Value), CStr(cell.Value)
            On Error GoTo 0
        Next cell

        'disable all filters
        .AutoFilterMode = False

        'change "A1:C1" to headers address of your table
        Set rngHeader = .Range("A1:C1")

        For Each nm In names
            With rngHeader
                'Apply filter to "Name" column
                .AutoFilter Field:=1, Criteria1:=nm
                On Error Resume Next
                'get all visible rows 
                Set res = .Offset(2).Resize(lastrow - 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0

                'if there is visible rows, create new WB
                If Not res Is Nothing Then
                    'create new workbook
                    Set wb = Workbooks.Add
                    'add sheet with name form column "Names" ("Paul", "Nick" or etc)
                    wb.Worksheets.Add.name = nm
                    'delete other sheets from new wb
                    For Each ws1 In wb.Worksheets
                        If ws1.name <> nm Then ws1.Delete
                    Next

                    'copy/paste data
                    With wb.Worksheets(nm)
                        'copy headers
                        .Range("A1").Resize(, rngHeader.Columns.Count).Value = rngHeader.Value
                        'copy data
                        .Range("A2").Resize(res.Rows.Count, res.Columns.Count).Value = res.Value
                    End With

                    'save wb
                    wb.Close saveChanges:=True, Filename:=ThisWorkbook.Path & "\Spreadsheet_" & nm & ".xlsx"
                    Set wb = Nothing
                End If
            End With
        Next
        'disable all filters
        .AutoFilterMode = False
    End With

    Set names = Nothing

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Answer 1

您的代码中有一部分声明它复制/粘贴数据：

            'copy/paste data
            With wb.Worksheets(nm)
                'copy headers
                .Range("A1").Resize(, rngHeader.Columns.Count).Formula = rngHeader.Formula
                'copy data
                .Range("A2").Resize(res.Rows.Count, res.Columns.Count).Formula = res.Formula
            End With

如果您复制.Formula而不是.Value，那么它应该有效。试一试，让我们知道。

修改宏以使用范围和保留公式进行复制和粘贴

1 个答案: