Làm sao chỉ tách 1 sheet thành nhiều file trong Excel, tuy nhiên vẫn giữ nguyên các sheet còn lại?

Liên hệ QC
V

Vivian0309

Thành viên mới
Tham gia
15/7/20
Bài viết
6
Được thích
0
Giới tính
Nữ
Dear cả nhà,

Hiện tại em đang có 1 file excel gồm nhiều sheet:
  • 1 sheet data tổng, bao gồm các dữ liệu như Tên người bán hàng, tên khách hàng, sales, tháng, quý....
  • 10 sheet còn lại là pivot từ sheet data tổng, có các chart biểu đồ tự động link với dữ liệu sheet data tổng.
=> Em đang cần gửi data cho mỗi Tên người bán hàng => Cần phải tách sheet data tổng thành nhiều filel Excel, tương ứng với Tên người bán hàng. Tuy nhiên vẫn cần giữ nguyên các sheet biểu đồ còn lại.

Cả nhà mình có ai biết hỗ trợ giúp em phần này với ạ.

Cảm ơn cả nhà nhiều.
PS: Em sẽ share file cụ thể với anh chị nào tách giúp em ạ.
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Vivian0309 đã viết:
Dear cả nhà,

Hiện tại em đang có 1 file excel gồm nhiều sheet:
  • 1 sheet data tổng, bao gồm các dữ liệu như Tên người bán hàng, tên khách hàng, sales, tháng, quý....
  • 10 sheet còn lại là pivot từ sheet data tổng, có các chart biểu đồ tự động link với dữ liệu sheet data tổng.
=> Em đang cần gửi data cho mỗi Tên người bán hàng => Cần phải tách sheet data tổng thành nhiều filel Excel, tương ứng với Tên người bán hàng. Tuy nhiên vẫn cần giữ nguyên các sheet biểu đồ còn lại.

Cả nhà mình có ai biết hỗ trợ giúp em phần này với ạ.

Cảm ơn cả nhà nhiều.
PS: Em sẽ share file cụ thể với anh chị nào tách giúp em ạ.
Nhấp chuột vào đây để mở rộng...
đưa file lên thì người ta mới biết là giúp dc hay không chứ bạn???
 
Upvote 0
Vivian0309 đã viết:
Em đính kèm file nhé. Sheet cần tách là Total.data. Tách theo EmpName.
Cảm ơn cả nhà.
Nhấp chuột vào đây để mở rộng...
Bạn thử code dưới đây xem ổn không
Mã: 
Sub taofile()
Dim sArr, i As Long
Dim Str As String, Fname As String
Dim Wb As Workbook

With Sheets("Total.Data")
    Lr = .Range("N50000").End(xlUp).Row
    sArr = .Range("N2:N" & Lr).Value
    For i = 1 To UBound(sArr)
        If InStr(Str, sArr(i, 1)) = 0 Then
            Str = Str & sArr(i, 1)
            Fname = ThisWorkbook.Path & "\" & sArr(i, 1) & ".xlsx"
            .Range("$A$1:$AD$" & Lr).AutoFilter Field:=14, Criteria1:=sArr(i, 1)
            .Range("$A$1:$AD$" & Lr).Copy
            If Dir(Fname) <> "" Then
                MsgBox "File Name: " & sArr(i, 1) & ".xlsx" & " bi trùng"
            Else
                Workbooks.Add
                Set Wb = ActiveWorkbook
                With Wb
                    .Sheets("Sheet1").Paste
                    .SaveAs Filename:=Fname
                    .Close savechanges:=True
                End With
            End If
        End If
    Next i
    .ShowAllData
End With
Application.CutCopyMode = False
End Sub
nhé:
 
Upvote 0
nguyenthuy13388 đã viết:
Bạn thử code dưới đây xem ổn không
Mã: 
Sub taofile()
Dim sArr, i As Long
Dim Str As String, Fname As String
Dim Wb As Workbook

With Sheets("Total.Data")
    Lr = .Range("N50000").End(xlUp).Row
    sArr = .Range("N2:N" & Lr).Value
    For i = 1 To UBound(sArr)
        If InStr(Str, sArr(i, 1)) = 0 Then
            Str = Str & sArr(i, 1)
            Fname = ThisWorkbook.Path & "\" & sArr(i, 1) & ".xlsx"
            .Range("$A$1:$AD$" & Lr).AutoFilter Field:=14, Criteria1:=sArr(i, 1)
            .Range("$A$1:$AD$" & Lr).Copy
            If Dir(Fname) <> "" Then
                MsgBox "File Name: " & sArr(i, 1) & ".xlsx" & " bi trùng"
            Else
                Workbooks.Add
                Set Wb = ActiveWorkbook
                With Wb
                    .Sheets("Sheet1").Paste
                    .SaveAs Filename:=Fname
                    .Close savechanges:=True
                End With
            End If
        End If
    Next i
    .ShowAllData
End With
Application.CutCopyMode = False
End Sub
nhé:
Nhấp chuột vào đây để mở rộng...
Hi
nguyenthuy13388 đã viết:
Bạn thử code dưới đây xem ổn không
Mã: 
Sub taofile()
Dim sArr, i As Long
Dim Str As String, Fname As String
Dim Wb As Workbook

With Sheets("Total.Data")
    Lr = .Range("N50000").End(xlUp).Row
    sArr = .Range("N2:N" & Lr).Value
    For i = 1 To UBound(sArr)
        If InStr(Str, sArr(i, 1)) = 0 Then
            Str = Str & sArr(i, 1)
            Fname = ThisWorkbook.Path & "\" & sArr(i, 1) & ".xlsx"
            .Range("$A$1:$AD$" & Lr).AutoFilter Field:=14, Criteria1:=sArr(i, 1)
            .Range("$A$1:$AD$" & Lr).Copy
            If Dir(Fname) <> "" Then
                MsgBox "File Name: " & sArr(i, 1) & ".xlsx" & " bi trùng"
            Else
                Workbooks.Add
                Set Wb = ActiveWorkbook
                With Wb
                    .Sheets("Sheet1").Paste
                    .SaveAs Filename:=Fname
                    .Close savechanges:=True
                End With
            End If
        End If
    Next i
    .ShowAllData
End With
Application.CutCopyMode = False
End Sub
nhé:
Nhấp chuột vào đây để mở rộng...
Hi bạn,

Phần code này đã tách ra từng TDV A hoặc TDV B nhưng mà cũng delete luôn các sheet còn lại. :(
Bài đã được tự động gộp:

Quochuyhdbt đã viết:
là tách theo TDV A, TDV B đó hả
Nhấp chuột vào đây để mở rộng...
Đúng rồi bạn. Nhưng vẫn giữ nguyên các sheet còn lại (đánh số 1,2,3....).

Cảm ơn bạn nhé.
 
Lần chỉnh sửa cuối:
Upvote 0
phulien1902 đã viết:
Yêu cầu trên chưa đáp ứng được cho chủ Topic.
Nhấp chuột vào đây để mở rộng...
Do mình không đọc kỹ yêu cầu, tuy nhiên việc khó làm rồi chỉ còn việc dễ, để chủ thớt tự làm vậy
Bài đã được tự động gộp:

Vivian0309 đã viết:
Hi

Hi bạn,

Phần code này đã tách ra từng TDV A hoặc TDV B nhưng mà cũng delete luôn các sheet còn lại. :(
Bài đã được tự động gộp:


Đúng rồi bạn. Nhưng vẫn giữ nguyên các sheet còn lại (đánh số 1,2,3....).

Cảm ơn bạn nhé.
Nhấp chuột vào đây để mở rộng...
Chào bạn:
1. Minh không delete cái gì đi cả chỉ là tạo Wb mới và copy dữ liệu cần sang thôi
2. Việc copy các sheets còn lại sang WB mới được thực hiện như sau: Tạo vòng lặp duyệt qua các sheets, sau đó copy nó sang WB mới là được (tất nhiên là bỏ sheet "total.data" lại)

Bạn làm thử xem có được không nhé.
 
Lần chỉnh sửa cuối:
Upvote 0
nguyenthuy13388 đã viết:
Do mình không đọc kỹ yêu cầu, tuy nhiên việc khó làm rồi chỉ còn việc dễ, để chủ thớt tự làm vậy
Bài đã được tự động gộp:


Chào bạn:
1. Minh không delete cái gì đi cả chỉ là tạo Wb mới và copy dữ liệu cần sang thôi
2. Việc copy các sheets còn lại sang WB mới được thực hiện như sau: Tạo vòng lặp duyệt qua các sheets, sau đó copy nó sang WB mới là được (tất nhiên là bỏ sheet "total.data" lại)

Bạn làm thử xem có được không nhé.
Nhấp chuột vào đây để mở rộng...
nguyenthuy13388 đã viết:
Do mình không đọc kỹ yêu cầu, tuy nhiên việc khó làm rồi chỉ còn việc dễ, để chủ thớt tự làm vậy
Bài đã được tự động gộp:


Chào bạn:
1. Minh không delete cái gì đi cả chỉ là tạo Wb mới và copy dữ liệu cần sang thôi
2. Việc copy các sheets còn lại sang WB mới được thực hiện như sau: Tạo vòng lặp duyệt qua các sheets, sau đó copy nó sang WB mới là được (tất nhiên là bỏ sheet "total.data" lại)

Bạn làm thử xem có được không nhé.
Nhấp chuột vào đây để mở rộng...

Chủ thớt hoàn toàn không biết phần này nên nhờ cả nhà giúp cả nhà ơi. Help me help me!!! :((

Cảm ơn cả nhà nhiều.
 
Upvote 0
Vivian0309 đã viết:
Chủ thớt hoàn toàn không biết phần này nên nhờ cả nhà giúp cả nhà ơi. Help me help me!!! :((

Cảm ơn cả nhà nhiều.
Nhấp chuột vào đây để mở rộng...
Bạn thêm vào code mấy dòng dưới đây:
PHP: 
   For Each sh In Workbooks("Testing_Data sample_2020.07.15").Worksheets
                            If sh.Name <> "Total.Data" Then
                                sh.Copy After:=wb.Sheets(wb.Sheets.Count)
                            End If
                        Next sh

+ Code bổ sung:
PHP: 
Sub taofile()
    Dim sArr, i As Long
    Dim Str As String, Fname As String, sh As Worksheet
    Dim wb As Workbook
    With Sheets("Total.Data")
        Lr = .Range("N50000").End(xlUp).Row
        sArr = .Range("N2:N" & Lr).Value
        For i = 1 To UBound(sArr)
            If InStr(Str, sArr(i, 1)) = 0 Then
                Str = Str & sArr(i, 1)
                Fname = ThisWorkbook.Path & "\" & sArr(i, 1) & ".xlsx"
                .Range("$A$1:$AD$" & Lr).AutoFilter Field:=14, Criteria1:=sArr(i, 1)
                .Range("$A$1:$AD$" & Lr).Copy
                If Dir(Fname) <> "" Then
                    MsgBox "File Name: " & sArr(i, 1) & ".xlsx" & " bi trùng"
                Else
                    Workbooks.Add
                    Set wb = ActiveWorkbook
                    With wb
                        .Sheets("Sheet1").Paste
                        .SaveAs Filename:=Fname
                        For Each sh In Workbooks("Testing_Data sample_2020.07.15").Worksheets
                            If sh.Name <> "Total.Data" Then
                                sh.Copy After:=wb.Sheets(wb.Sheets.Count)
                            End If
                        Next sh
                        .Close savechanges:=True
                    End With
                End If
            End If
        Next i
        .ShowAllData
    End With
    Application.CutCopyMode = False
End Sub
 
Upvote 0
phulien1902 đã viết:
Bạn thêm vào code mấy dòng dưới đây:
PHP: 
   For Each sh In Workbooks("Testing_Data sample_2020.07.15").Worksheets
                            If sh.Name <> "Total.Data" Then
                                sh.Copy After:=wb.Sheets(wb.Sheets.Count)
                            End If
                        Next sh

+ Code bổ sung:
PHP: 
Sub taofile()
    Dim sArr, i As Long
    Dim Str As String, Fname As String, sh As Worksheet
    Dim wb As Workbook
    With Sheets("Total.Data")
        Lr = .Range("N50000").End(xlUp).Row
        sArr = .Range("N2:N" & Lr).Value
        For i = 1 To UBound(sArr)
            If InStr(Str, sArr(i, 1)) = 0 Then
                Str = Str & sArr(i, 1)
                Fname = ThisWorkbook.Path & "\" & sArr(i, 1) & ".xlsx"
                .Range("$A$1:$AD$" & Lr).AutoFilter Field:=14, Criteria1:=sArr(i, 1)
                .Range("$A$1:$AD$" & Lr).Copy
                If Dir(Fname) <> "" Then
                    MsgBox "File Name: " & sArr(i, 1) & ".xlsx" & " bi trùng"
                Else
                    Workbooks.Add
                    Set wb = ActiveWorkbook
                    With wb
                        .Sheets("Sheet1").Paste
                        .SaveAs Filename:=Fname
                        For Each sh In Workbooks("Testing_Data sample_2020.07.15").Worksheets
                            If sh.Name <> "Total.Data" Then
                                sh.Copy After:=wb.Sheets(wb.Sheets.Count)
                            End If
                        Next sh
                        .Close savechanges:=True
                    End With
                End If
            End If
        Next i
        .ShowAllData
    End With
    Application.CutCopyMode = False
End Sub
Nhấp chuột vào đây để mở rộng...

Cảm ơn bạn rất nhiều cho phần code này nha.
Mình đã tách ra được từng file với code này, và vẫn giữ nguyên các sheet còn lại rồi.

Tuy nhiên, đối với file vừa được tách, các sheet còn lại, dữ liệu của Pivot để làm biểu đồ vẫn còn đang lấy từ sheet dữ liệu "Total.data" trong file excel gốc của mình, không lấy trên sheet vừa được tách ra => Các TDV này vẫn thấy được dữ liệu của TDV khác.

Mình có cách nào để trong file vừa được tách ra, các sheet còn lại được link duy nhất với sheet vừa được tách không?
Cảm ơn cả nhà rất nhiều vì đã hỗ trợ nhé.
 
Upvote 0
Vivian0309 đã viết:
Cảm ơn bạn rất nhiều cho phần code này nha.
Mình đã tách ra được từng file với code này, và vẫn giữ nguyên các sheet còn lại rồi.

Tuy nhiên, đối với file vừa được tách, các sheet còn lại, dữ liệu của Pivot để làm biểu đồ vẫn còn đang lấy từ sheet dữ liệu "Total.data" trong file excel gốc của mình, không lấy trên sheet vừa được tách ra => Các TDV này vẫn thấy được dữ liệu của TDV khác.

Mình có cách nào để trong file vừa được tách ra, các sheet còn lại được link duy nhất với sheet vừa được tách không?
Cảm ơn cả nhà rất nhiều vì đã hỗ trợ nhé.
Nhấp chuột vào đây để mở rộng...
Bạn thử code dưới nhé:
Mã: 
Sub taofile()
Dim sArr, i As Long
Dim Str As String, Fname As String, sh As Worksheet
Dim wb As Workbook
Dim pv As PivotTable

Application.ScreenUpdating = False
With Sheets("Total.Data")
    Lr = .Range("N50000").End(xlUp).Row
    sArr = .Range("N2:N" & Lr).Value
    For i = 1 To UBound(sArr)
        If InStr(Str, sArr(i, 1)) = 0 Then
            Str = Str & sArr(i, 1)
            Fname = ThisWorkbook.Path & "\" & sArr(i, 1) & ".xlsx"
            .Range("$A$1:$AD$" & Lr).AutoFilter Field:=14, Criteria1:=sArr(i, 1)
            .Range("$A$1:$AD$" & Lr).Copy
            If Dir(Fname) <> "" Then
                MsgBox "File Name: " & sArr(i, 1) & ".xlsx" & " bi trùng"
            Else
                Workbooks.Add
                Set wb = ActiveWorkbook
                With wb
                    .Sheets("Sheet1").Paste
                    .SaveAs Filename:=Fname
                    For Each sh In Workbooks("Testing_Data sample_2020.07.15").Worksheets
                        If sh.Name <> "Total.Data" Then
                            sh.Copy After:=wb.Sheets(wb.Sheets.Count)
                            With ActiveSheet
                                For Each pv In .PivotTables
                                    With pv
                                        pv.SourceData = "'Sheet1'!R1C1:R10000C30"
                                    End With
                                Next pv
                            End With
                        End If
                    Next sh
                    .Close savechanges:=True
                End With
            End If
        End If
    Next i
    .ShowAllData
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
 
Upvote 0
nguyenthuy13388 đã viết:
Bạn thử code dưới nhé:
Mã: 
Sub taofile()
Dim sArr, i As Long
Dim Str As String, Fname As String, sh As Worksheet
Dim wb As Workbook
Dim pv As PivotTable

Application.ScreenUpdating = False
With Sheets("Total.Data")
    Lr = .Range("N50000").End(xlUp).Row
    sArr = .Range("N2:N" & Lr).Value
    For i = 1 To UBound(sArr)
        If InStr(Str, sArr(i, 1)) = 0 Then
            Str = Str & sArr(i, 1)
            Fname = ThisWorkbook.Path & "\" & sArr(i, 1) & ".xlsx"
            .Range("$A$1:$AD$" & Lr).AutoFilter Field:=14, Criteria1:=sArr(i, 1)
            .Range("$A$1:$AD$" & Lr).Copy
            If Dir(Fname) <> "" Then
                MsgBox "File Name: " & sArr(i, 1) & ".xlsx" & " bi trùng"
            Else
                Workbooks.Add
                Set wb = ActiveWorkbook
                With wb
                    .Sheets("Sheet1").Paste
                    .SaveAs Filename:=Fname
                    For Each sh In Workbooks("Testing_Data sample_2020.07.15").Worksheets
                        If sh.Name <> "Total.Data" Then
                            sh.Copy After:=wb.Sheets(wb.Sheets.Count)
                            With ActiveSheet
                                For Each pv In .PivotTables
                                    With pv
                                        pv.SourceData = "'Sheet1'!R1C1:R10000C30"
                                    End With
                                Next pv
                            End With
                        End If
                    Next sh
                    .Close savechanges:=True
                End With
            End If
        End If
    Next i
    .ShowAllData
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Cảm ơn phần code của bạn rất nhiều. Mình thấy file tách đúng như mong muốn của mình 99% rồi. Còn 1% rơi vào trường hợp bên dưới:

Vì dữ liệu của Pivot để làm biểu đồ vẫn còn đang lấy từ sheet dữ liệu "Total.data" trong file excel gốc của mình => Trong trường hợp người nhận file được tách có điều chỉnh một số thông tin trong "sheet 1", các dữ liệu các sheet Pvt còn lại sẽ không thay đổi (data range cho Pivot mình dùng Offset).

Mình có cách nào dữ liệu Pvt cũng động theo "sheet 1", chứ không phải Total.data trong file gốc của mình không?

Lần đầu tiên tham gia các diễn đàn dạng này, rất biết ơn cả nhà dù không quen biết vẫn giúp đỡ mình rất nhiều nhé. :)
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
32
Đọc
815
VetMini
V
K
Nhờ mọi người hoàn thiện giúp công thức
Trả lời
4
Đọc
87
kiendt1973
K
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11/2024
    • Thích
    • Yêu thích
Trả lời
0
Đọc
52
GPE-Trợ Lý
GPE-Trợ Lý
dovanha1994
Giúp e tìm nguyên nhân sai và hướng dẫn e đọc file này với ạ
    • Phẫn nộ
Trả lời
3
Đọc
94
dovanha1994
dovanha1994
N
Giúp sửa mã code
Trả lời
19
Đọc
400
ptm0412
ptm0412
P
Nhờ giúp đỡ hàm lọc dữ liệu theo tỉnh
Trả lời
10
Đọc
164
Parabol
P
CodyPham97
tạo biểu tượng thay thế nhấn đúp chuột
Trả lời
1
Đọc
51
BuiQuangThuan
B
H
Chúc mừng 20/11- ngày tôn vinh nhà giáo Việt Nam.
    • Thích
    • Yêu thích
Trả lời
0
Đọc
56
HUONGHCKT
H
F
  • Question
Nhờ tư vấn cách tạo QR trong Excel
Trả lời
4
Đọc
445
hoangtuan.net
hoangtuan.net
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
7
Đọc
189
Ny Ny 2024
N
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
9
Đọc
457
bibuzz90
B
Nhật Anh 9x
  • Question
Tính tồn cuối kỳ luỹ kế cho nhiều mã
Trả lời
2
Đọc
96
Nhật Anh 9x
Nhật Anh 9x
H
Hỗ trợ lấy danh sách dữ liệu thỏa mãn điều kiện
Trả lời
1
Đọc
80
bebo021999
B
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
2
Trả lời
20
Đọc
560
ptm0412
ptm0412
nguyen trung cuong
File chứa marco không mở được.
Trả lời
2
Đọc
72
nguyen trung cuong
nguyen trung cuong
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
1
Đọc
114
hvnhpro
H
nobita994
Trừ số lượng dần theo dòng khi quét Sumif tổng có tên sản phẩm bị trùng.
Trả lời
2
Đọc
77
bebo021999
B
PhanTuHuong
Bàn về môn thể thao bóng bàn nào!
    • Thích
    • Yêu thích
    • Cười
2
Trả lời
37
Đọc
2K
cantl
C
S
  • Question
Xin file excel bảng giá quần áo, trang phục, phụ kiện
Trả lời
2
Đọc
79
VetMini
V
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
19
Đọc
384
VetMini
V
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom