Giúp tách 2 sheet thành nhiều file (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
T

tueyennhi

Thành viên tích cực
Tham gia
18/10/10
Bài viết
1,192
Được thích
105
Dear anh chị. Em có file đính kèm, anh chị giúp em làm thế nào để có thể tách các sheet này thành nhiều sheet với điều kiện sau:

Trong file có 2 sheet Sign và Check, 2 sheet này đều dựa vào cột E (bộ phận) để tách
Em muốn sheet sau khi tách thành file thì:
- Tên file là tên bộ phận.
- Mỗi file được tách ra sẽ chứa 2 sheet Sign và Check mà dữ liệu chỉ bao gồm bộ phận đó.
- File khi tách ra được giữ nguyên định dạng ban đầu
- Dòng thứ 3 có phần thông tin bộ phận mọi người cũng thêm vào giúp em nhé ví dụ tách của ACC thì dòng 3 sẽ là Bộ phận: ACC

Mong mọi người chỉ giúp!
Em cảm ơn!

Nếu như bài toán này bất khả thi thì nhờ mọi người tách thử cho em sheet Sign thành nhiều file được không?
 

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
tueyennhi đã viết:
Dear anh chị. Em có file đính kèm, anh chị giúp em làm thế nào để có thể tách các sheet này thành nhiều sheet với điều kiện sau:

Trong file có 2 sheet Sign và Check, 2 sheet này đều dựa vào cột E (bộ phận) để tách
Em muốn sheet sau khi tách thành file thì:
- Tên file là tên bộ phận.
- Mỗi file được tách ra sẽ chứa 2 sheet Sign và Check mà dữ liệu chỉ bao gồm bộ phận đó.
- File khi tách ra được giữ nguyên định dạng ban đầu
- Dòng thứ 3 có phần thông tin bộ phận mọi người cũng thêm vào giúp em nhé ví dụ tách của ACC thì dòng 3 sẽ là Bộ phận: ACC

Mong mọi người chỉ giúp!
Em cảm ơn!

Nếu như bài toán này bất khả thi thì nhờ mọi người tách thử cho em sheet Sign thành nhiều file được không?
Nhấp chuột vào đây để mở rộng...
Code này sẽ tạo file với tên file là tên của bộ phận, lưu trữ cùng thư mục với file gốc bạn nhé!
Mã: 
Sub Split_files()
    Dim Dic As Object
    Dim sArr(), tArr(), dArr(), Arr(), iArr(), Wk As Workbook
    Dim I As Long, J As Long, K As Long, N As Long, H As Long
    
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown)).Resize(, 33).Value
    Arr = Sheet2.Range("A8", Sheet2.Range("A8").End(xlDown)).Resize(, 17).Value
    For I = 1 To UBound(sArr, 1)
        If Not Dic.Exists(sArr(I, 5)) Then Dic.Add sArr(I, 5), ""
    Next I
  
    tArr = Dic.Keys
    Application.ScreenUpdating = False
    For J = 0 To UBound(tArr)
        K = 0
        H = 0
        ReDim dArr(1 To UBound(sArr), 1 To 33)
        ReDim iArr(1 To UBound(Arr), 1 To 17)
        For I = 1 To UBound(sArr, 1)
            If tArr(J) = sArr(I, 5) Then
                K = K + 1
                For N = 1 To 33
                    dArr(K, N) = sArr(I, N)
                Next N
            End If
        Next I
        For I = 1 To UBound(Arr, 1)
            If tArr(J) = Arr(I, 5) Then
                H = H + 1
                For N = 1 To 17
                    iArr(H, N) = Arr(I, N)
                Next N
            End If
        Next I
        Set Wk = Workbooks.Add
        With Wk
            Sheet1.Range("A1:AG7").Copy .Worksheets(1).Range("A1")
            .Worksheets(1).Range("A8").Resize(K, 33) = dArr
            .Worksheets(1).Columns("A:AG").AutoFit
            .Sheets.Add , ActiveSheet
            Sheet2.Range("A1:Q7").Copy .Worksheets(2).Range("A1")
            .Worksheets(2).Range("A8").Resize(H, 17) = iArr
            .Worksheets(2).Columns("A:Q").AutoFit
            .SaveAs ThisWorkbook.Path & "\" & tArr(J) & ".xlsx"
            .Close
        End With
        Erase dArr
        Erase iArr
    Next J
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub
 
Upvote 0
vanthinh3101 đã viết:
Code này sẽ tạo file với tên file là tên của bộ phận, lưu trữ cùng thư mục với file gốc bạn nhé!
Mã: 
Sub Split_files()
    Dim Dic As Object
    Dim sArr(), tArr(), dArr(), Arr(), iArr(), Wk As Workbook
    Dim I As Long, J As Long, K As Long, N As Long, H As Long
   
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown)).Resize(, 33).Value
    Arr = Sheet2.Range("A8", Sheet2.Range("A8").End(xlDown)).Resize(, 17).Value
    For I = 1 To UBound(sArr, 1)
        If Not Dic.Exists(sArr(I, 5)) Then Dic.Add sArr(I, 5), ""
    Next I
 
    tArr = Dic.Keys
    Application.ScreenUpdating = False
    For J = 0 To UBound(tArr)
        K = 0
        H = 0
        ReDim dArr(1 To UBound(sArr), 1 To 33)
        ReDim iArr(1 To UBound(Arr), 1 To 17)
        For I = 1 To UBound(sArr, 1)
            If tArr(J) = sArr(I, 5) Then
                K = K + 1
                For N = 1 To 33
                    dArr(K, N) = sArr(I, N)
                Next N
            End If
        Next I
        For I = 1 To UBound(Arr, 1)
            If tArr(J) = Arr(I, 5) Then
                H = H + 1
                For N = 1 To 17
                    iArr(H, N) = Arr(I, N)
                Next N
            End If
        Next I
        Set Wk = Workbooks.Add
        With Wk
            Sheet1.Range("A1:AG7").Copy .Worksheets(1).Range("A1")
            .Worksheets(1).Range("A8").Resize(K, 33) = dArr
            .Worksheets(1).Columns("A:AG").AutoFit
            .Sheets.Add , ActiveSheet
            Sheet2.Range("A1:Q7").Copy .Worksheets(2).Range("A1")
            .Worksheets(2).Range("A8").Resize(H, 17) = iArr
            .Worksheets(2).Columns("A:Q").AutoFit
            .SaveAs ThisWorkbook.Path & "\" & tArr(J) & ".xlsx"
            .Close
        End With
        Erase dArr
        Erase iArr
    Next J
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhé, để mình thử.
 
Upvote 0
Mình thử rồi, code bị mất chút định dạng và tên sheet là sheet 1 sheet 2. Nhưng như vậy cũng là quá tuyệt rồi, tốc độ rất nhanh :). Cảm ơn rất nhiều!
 
Upvote 0
tueyennhi đã viết:
Mình thử rồi, code bị mất chút định dạng và tên sheet là sheet 1 sheet 2. Nhưng như vậy cũng là quá tuyệt rồi, tốc độ rất nhanh :). Cảm ơn rất nhiều!
Nhấp chuột vào đây để mở rộng...
Đổi tên sheet, đo thời gian và giữ lại định dạng như file gốc bạn nhé!
Mã: 
Sub Split_files()
    Dim Dic As Object
    Dim sArr(), tArr(), dArr(), Arr(), iArr(), Wk As Workbook
    Dim I As Long, J As Long, K As Long, N As Long, H As Long, t
    
    t = Timer
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown)).Resize(, 33).Value
    Arr = Sheet2.Range("A8", Sheet2.Range("A8").End(xlDown)).Resize(, 17).Value
    For I = 1 To UBound(sArr, 1)
        If Not Dic.Exists(sArr(I, 5)) Then Dic.Add sArr(I, 5), ""
    Next I
 
    tArr = Dic.Keys
    Application.ScreenUpdating = False
    For J = 0 To UBound(tArr)
        K = 0
        H = 0
        ReDim dArr(1 To UBound(sArr), 1 To 33)
        ReDim iArr(1 To UBound(Arr), 1 To 17)
        For I = 1 To UBound(sArr, 1)
            If tArr(J) = sArr(I, 5) Then
                K = K + 1
                For N = 1 To 33
                    dArr(K, N) = sArr(I, N)
                Next N
            End If
        Next I
        For I = 1 To UBound(Arr, 1)
            If tArr(J) = Arr(I, 5) Then
                H = H + 1
                For N = 1 To 17
                    iArr(H, N) = Arr(I, N)
                Next N
            End If
        Next I
        Set Wk = Workbooks.Add
        With Wk
            Sheet1.Range("A1:AG7").Copy .Worksheets(1).Range("A1")
            .Worksheets(1).Range("A8").Resize(K, 33) = dArr
            .Worksheets(1).Columns("A:AG").AutoFit
            .Worksheets(1).Name = "Sign"
            With .Worksheets(1).Range("A7", .Worksheets(1).Range("A7").End(xlDown)).Resize(, 33)
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
                .Borders(xlInsideVertical).Weight = xlHairline
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Font.Name = "Times New Roman"
                .Font.Size = 7
                .Offset(1, 7).Resize(.Rows.Count - 1, 21).NumberFormat = "0.0"
            End With
            .Sheets.Add , ActiveSheet
            Sheet2.Range("A1:Q7").Copy .Worksheets(2).Range("A1")
            .Worksheets(2).Range("A8").Resize(H, 17) = iArr
            .Worksheets(2).Columns("A:Q").AutoFit
            .Worksheets(2).Name = "Check"
            With .Worksheets(2).Range("A7", .Worksheets(2).Range("A7").End(xlDown)).Resize(, 17)
                .Borders.LineStyle = 1
                .Offset(1).Resize(.Rows.Count - 1, 6).Font.Name = "Arial"
                .Offset(1).Resize(.Rows.Count - 1, 6).Font.Size = 8
                .Offset(1, 6).Resize(.Rows.Count - 1, 2).Font.Name = "Cambria"
                .Offset(1, 6).Resize(.Rows.Count - 1, 2).Font.Size = 8
                .Offset(1, 8).Resize(.Rows.Count - 1, 8).Font.Name = "Times New Roman"
                .Offset(1, 8).Resize(.Rows.Count - 1, 8).Font.Size = 7
                .Offset(1, 8).Resize(.Rows.Count - 1, 8).Style = "Comma"
                .Offset(1, 15).Resize(.Rows.Count - 1, 1).Font.Bold = True
            End With
            .SaveAs ThisWorkbook.Path & "\" & tArr(J) & ".xlsx"
            .Close
        End With
        Erase dArr
        Erase iArr
    Next J
    Application.ScreenUpdating = True
    MsgBox "Done in " & Int(Timer - t) & " s.", vbInformation, "GPE"

    Set Dic = Nothing
End Sub
 
Upvote 0
vanthinh3101 đã viết:
Đổi tên sheet, đo thời gian và giữ lại định dạng như file gốc bạn nhé!
Mã: 
Sub Split_files()
    Dim Dic As Object
    Dim sArr(), tArr(), dArr(), Arr(), iArr(), Wk As Workbook
    Dim I As Long, J As Long, K As Long, N As Long, H As Long, t
   
    t = Timer
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown)).Resize(, 33).Value
    Arr = Sheet2.Range("A8", Sheet2.Range("A8").End(xlDown)).Resize(, 17).Value
    For I = 1 To UBound(sArr, 1)
        If Not Dic.Exists(sArr(I, 5)) Then Dic.Add sArr(I, 5), ""
    Next I
 
    tArr = Dic.Keys
    Application.ScreenUpdating = False
    For J = 0 To UBound(tArr)
        K = 0
        H = 0
        ReDim dArr(1 To UBound(sArr), 1 To 33)
        ReDim iArr(1 To UBound(Arr), 1 To 17)
        For I = 1 To UBound(sArr, 1)
            If tArr(J) = sArr(I, 5) Then
                K = K + 1
                For N = 1 To 33
                    dArr(K, N) = sArr(I, N)
                Next N
            End If
        Next I
        For I = 1 To UBound(Arr, 1)
            If tArr(J) = Arr(I, 5) Then
                H = H + 1
                For N = 1 To 17
                    iArr(H, N) = Arr(I, N)
                Next N
            End If
        Next I
        Set Wk = Workbooks.Add
        With Wk
            Sheet1.Range("A1:AG7").Copy .Worksheets(1).Range("A1")
            .Worksheets(1).Range("A8").Resize(K, 33) = dArr
            .Worksheets(1).Columns("A:AG").AutoFit
            .Worksheets(1).Name = "Sign"
            With .Worksheets(1).Range("A7", .Worksheets(1).Range("A7").End(xlDown)).Resize(, 33)
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
                .Borders(xlInsideVertical).Weight = xlHairline
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Font.Name = "Times New Roman"
                .Font.Size = 7
                .Offset(1, 7).Resize(.Rows.Count - 1, 21).NumberFormat = "0.0"
            End With
            .Sheets.Add , ActiveSheet
            Sheet2.Range("A1:Q7").Copy .Worksheets(2).Range("A1")
            .Worksheets(2).Range("A8").Resize(H, 17) = iArr
            .Worksheets(2).Columns("A:Q").AutoFit
            .Worksheets(2).Name = "Check"
            With .Worksheets(2).Range("A7", .Worksheets(2).Range("A7").End(xlDown)).Resize(, 17)
                .Borders.LineStyle = 1
                .Offset(1).Resize(.Rows.Count - 1, 6).Font.Name = "Arial"
                .Offset(1).Resize(.Rows.Count - 1, 6).Font.Size = 8
                .Offset(1, 6).Resize(.Rows.Count - 1, 2).Font.Name = "Cambria"
                .Offset(1, 6).Resize(.Rows.Count - 1, 2).Font.Size = 8
                .Offset(1, 8).Resize(.Rows.Count - 1, 8).Font.Name = "Times New Roman"
                .Offset(1, 8).Resize(.Rows.Count - 1, 8).Font.Size = 7
                .Offset(1, 8).Resize(.Rows.Count - 1, 8).Style = "Comma"
                .Offset(1, 15).Resize(.Rows.Count - 1, 1).Font.Bold = True
            End With
            .SaveAs ThisWorkbook.Path & "\" & tArr(J) & ".xlsx"
            .Close
        End With
        Erase dArr
        Erase iArr
    Next J
    Application.ScreenUpdating = True
    MsgBox "Done in " & Int(Timer - t) & " s.", vbInformation, "GPE"

    Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Có một vấn đề mình thấy phát sinh là nếu như cột bộ phận của 1 trong hai sheet bắt buộc phải đều có nếu không sẽ báo lỗi.
 
Upvote 0
tueyennhi đã viết:
Có một vấn đề mình thấy phát sinh là nếu như cột bộ phận của 1 trong hai sheet bắt buộc phải đều có nếu không sẽ báo lỗi.
Nhấp chuột vào đây để mở rộng...
Code được viết dựa trên mẫu dữ liệu của bạn đưa lên.
Nếu bạn đã lường trước được những hạn chế có thể xảy ra, bạn nên đưa ra dữ liệu đã được giả định trong trường hợp đó để mọi người cùng tham khảo và đưa ra giải pháp nhé!
 
Upvote 0
vanthinh3101 đã viết:
Code được viết dựa trên mẫu dữ liệu của bạn đưa lên.
Nếu bạn đã lường trước được những hạn chế có thể xảy ra, bạn nên đưa ra dữ liệu đã được giả định trong trường hợp đó để mọi người cùng tham khảo và đưa ra giải pháp nhé!
Nhấp chuột vào đây để mở rộng...
Chúc mừng năm mới :)!!!!
 
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

T
Tô màu ảnh bác Hồ bằng Conditional Formatting (2 người xem)
Trả lời
2
Đọc
56
thuctien
T
M
File excel ứng dụng trong nhập xuất kho, thu chi, bán hàng và công nợ
    • Thích
    • Yêu thích
    • Cảm ơn
7 8 9
Trả lời
166
Đọc
31K
giangsimso
G
K
lấy dữ liệu từ excel sang worrd
Trả lời
1
Đọc
45
thuytrangbp28
T
chickenexcel
xin hướng dẫn code chọn hình ảnh trong file (1 người xem)
Trả lời
4
Đọc
148
thuytrangbp28
T
T
Cách cộng tổng chính xác nhất (1 người xem)
Trả lời
7
Đọc
249
THANH657
T
GPE-Trợ Lý
ĐĂNG KÝ THAM DỰ SINH NHẬT GPE TẠI HN - SỰ KIỆN TALKSHOW ĐẶC BIỆT
    • Thích
2
Trả lời
26
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
L
xin anh chị giúp em công thức tính tổng năm theo điều kiện ạ (1 người xem)
Trả lời
9
Đọc
240
HieuCD
H
Y
Lấy dữ liệu từ nhiều sheet khác nhau.
2
Trả lời
20
Đọc
617
lib.enigma
L
Nguyễn Duy Tuân
  • Dán lên cao
Sử dụng AI trong Excel với Add-in A-Tools AI v10
    • Thích
    • Cảm ơn
Trả lời
8
Đọc
902
Nguyễn Duy Tuân
Nguyễn Duy Tuân
T
In lặp lại nhiều dòng ở cuối các trang
Trả lời
13
Đọc
454
Hoàng Tuấn 868
H
K
Tạo mã thiết bị
Trả lời
10
Đọc
280
khoailang
K
C
Xin file lên thực đơn và định lượng món ăn cho suất ăn công nghiệp
Trả lời
0
Đọc
83
Chihuong_vp90
C
T
Lỗi Khi Mở File Excel
Trả lời
3
Đọc
118
Hoàng Tuấn 868
H
H
Em chào anh chị ạ.Em cần xếp lịch nghỉ randum cho 1 số nhóm làm việc trong 1 công ty.
Trả lời
4
Đọc
159
Duy Tùng 9x
Duy Tùng 9x
1
Em hỏi chút về hàm điều kiện với liệt kê
Trả lời
2
Đọc
149
123456it
1
tramcannt
data validation (1 người xem)
Trả lời
2
Đọc
136
ptm0412
ptm0412
giaiphap
Add-Ins cho Excel 2007 -2016 32bit và 64bit
    • Thích
    • Yêu thích
    • Ngạc nhiên
24 25 26
Trả lời
514
Đọc
204K
hoangtuan.net
hoangtuan.net
Nguyễn Duy Tuân
  • Dán lên cao
Phiên bản mới Add-in A-Tools AI v10 (2024)
    • Thích
2 3
Trả lời
56
Đọc
7K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
Lỗi syntax error
Trả lời
2
Đọc
131
ptm0412
ptm0412
H
Xin các bác giúp đỡ cách đổi thời gian thành số thập phân
Trả lời
8
Đọc
179
huyphanthieu
H
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

Sinh nhật lần 19 GPE

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom