Sửa code: để có thể tách file từ sheet Data mà vẫn bao gồm cấu trúc privot ở các sheet còn lại

[tieutuvodanh192]

Kinh gửi các anh/chị trong diễn đàn:

Với file hiện tại em có thể tách dữ liệu từ 1 sheet ra thành nhiều file khác nhau theo trường ở cột CI, tuy nhiên trường hợp của em có 1 file có nhiều sheet, trong đó em muốn tách dữ liệu ở sheet Data ra mà vẫn giữ nguyên các sheet khác có chứa bảng privot, ở file đã tách em sẽ chỉ refresh lại là có bảng privot mới.
Rất mong nhận được sự giúp đỡ !

Sub Main()
  Dim dic As Object, rngSrc As Range, wkbNew As Workbook
  Dim aIDs, n As Long
  Dim sFolder As String, FileName As String, SheetName As String
  sFolder = ThisWorkbook.Path & "\"
  Set rngSrc = ThisWorkbook.Worksheets("Data").Range("A1:CJ10000")
  aIDs = rngSrc.Offset(1).Columns("CI:CJ").Value
  Set dic = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  rngSrc.Range("IV1").Value = rngSrc.Range("CI1").Value
  For n = 1 To UBound(aIDs, 1)
    If Len(aIDs(n, 1)) And Len(aIDs(n, 1)) Then
      SheetName = aIDs(n, 1):  FileName = aIDs(n, 1)
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, Empty
        Set wkbNew = Workbooks.Add(1)
        wkbNew.Sheets(1).Name = "Data"
        rngSrc.Range("IV2").Value = "'=" & SheetName
        rngSrc.AdvancedFilter 2, rngSrc.Range("IV1:IV2"), wkbNew.Sheets(1).Range("A1")
        wkbNew.SaveAs sFolder & FileName, xlOpenXMLWorkbook
        wkbNew.Close False
      End If
    End If
  Next
  Application.ScreenUpdating = True
  rngSrc.Range("IV1:IV2").ClearContents
  If dic.Count Then MsgBox "Đa luu " & dic.Count & " workbooks", , "THÔNG BÁO"
End Sub