Cách giữ công thức khi lọc và tách file (6 người xem)

[nttrung_proneu]

Xin chào các anh/ chị/ em,
Nhờ mọi người gỡ giúp em vấn đề này với ạ,
Em muốn tách file bằng cách lọc đối tượng và copy paste, nhưng không hiểu sao cứ bị mất công thức ở cột G.
Vì đây là file chưa điền dữ liệu nhưng phải tách ra để gửi đi cho người khác điền, nên cần giữ lại công thức tính toán này ạ.
Dưới đây là code và file đính kèm, nhờ mọi người giúp đỡ ạ, em xin cảm ơn nhiều nhiều!

Option Explicit
Sub Xacnhan()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Dim wb, bp As Workbook
    Dim d, r, i As Long
    Dim path, ten As String
    Dim fso As Object
    
    On Error Resume Next
    
        Set wb = ActiveWorkbook
        With wb
            .Sheets(1).AutoFilterMode = False
            d = .Sheets(1).Range("H" & Rows.Count).End(xlUp).Row
            .Sheets(1).Range("B2:H" & d).AutoFilter
            r = .Sheets(2).Range("B1").End(xlDown).Row
            .Sheets(2).Range("Z1").FormulaR1C1 = "=LEFT(CELL(""filename""),FIND(""["",CELL(""filename""))-1)"
            path = .Sheets(2).Range("Z1").Value & "Thang " & .Sheets(2).Range("A2").Value
            Set fso = CreateObject("Scripting.FileSystemObject")
            If (Not fso.FolderExists(path)) Then fso.CreateFolder (path)
            
            For i = 2 To r
                .Sheets(1).Range("B2:H" & d).AutoFilter Field:=7, Criteria1:=.Sheets(2).Range("B" & i).Value
                Application.CutCopyMode = False
                .Sheets(1).Range("A1:H" & d).Copy
                
                Set bp = Workbooks.Add
                ten = path & "\" & .Sheets(2).Range("B" & i).Value & ".xlsx"
                                
                bp.Sheets(1).Activate
                bp.Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
                bp.Sheets(1).Paste
                                
                bp.SaveAs Filename:=ten
                bp.Close
                                
            Next i
            .Sheets(1).ShowAllData
            .Sheets(2).Range("Z1").ClearContents
        End With
        
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

 

[minhminh27]

thử sửa đoạn code của bạn

     bp.Sheets(1).Activate
                bp.Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
                bp.Sheets(1).Paste

sang

bp.Sheets(1).Activate
bp.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
bp.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll

 

[nttrung_proneu]

thử sửa đoạn code của bạn

     bp.Sheets(1).Activate
                bp.Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
                bp.Sheets(1).Paste

sang

bp.Sheets(1).Activate
bp.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
bp.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll

WOA,
Kết quả đã đúng với mong muốn rồi bác ơi,
Logic thật ảo diệu, em cảm ơn bác rất nhiều ạ!!!