Tách sheet và Save File theo điều kiện

ngoctuyen1995 · 28/3/23

Thân chào cả nhà GPEX.!
Em có bài toán này mà chưa biết giải quyết ra sao, mong cả nhà giúp đỡ ạ

Em có 02 File:
File Danh Sach và File Data_Total (gần 100 sheet)
Ấn vào nút Run:
sẽ tự động Tách Sheet theo điều kiện Code Sold To (Cột B) File Danh Sach Map với điều kiện Range("C15") theo từng sheet ở File Data_Total, nếu thỏa điều kiện thì sẽ save File theo tên của cột Region (Nếu cùng chung 1 Region thì sẽ nằm Chung 1 File)

Em có làm File Demo Kết Quả và đính kèm ạ
Rất mong sợ giúp đỡ cua cả nhà, em chân thành cảm ơn ạ.

snow25 · 28/3/23

ngoctuyen1995 đã viết:
Thân chào cả nhà GPEX.!
Em có bài toán này mà chưa biết giải quyết ra sao, mong cả nhà giúp đỡ ạ

Em có 02 File:
File Danh Sach và File Data_Total (gần 100 sheet)
Ấn vào nút Run:
sẽ tự động Tách Sheet theo điều kiện Code Sold To (Cột B) File Danh Sach Map với điều kiện Range("C15") theo từng sheet ở File Data_Total, nếu thỏa điều kiện thì sẽ save File theo tên của cột Region (Nếu cùng chung 1 Region thì sẽ nằm Chung 1 File)

Em có làm File Demo Kết Quả và đính kèm ạ
Rất mong sợ giúp đỡ cua cả nhà, em chân thành cảm ơn ạ.

Tại sao không để chung vào 1 file mà lại để 2 file vậy bạn.Mất công mở file lên rồi lại đóng file.

ngoctuyen1995 · 28/3/23

snow25 đã viết:
Tại sao không để chung vào 1 file mà lại để 2 file vậy bạn.Mất công mở file lên rồi lại đóng file.

Dạ, vì nó là 2 File khác nhau ạ, File Data là bên đối tác họ gửi nên sẽ luôn thay đổi nên em không thể bỏ chung File với File list được ạ.

snow25 · 28/3/23

ngoctuyen1995 đã viết:
Dạ, vì nó là 2 File khác nhau ạ, File Data là bên đối tác họ gửi nên sẽ luôn thay đổi nên em không thể bỏ chung File với File list được ạ.

Ok nếu mai chưa ai code tôi code cho bạn.Hôm nay muộn rồi.

ngoctuyen1995 · 28/3/23

snow25 đã viết:
Ok nếu mai chưa ai code tôi code cho bạn.Hôm nay muộn rồi.

Vâng ạ, em cảm ơn anh

HUONGHCKT · 28/3/23

ngoctuyen1995 đã viết:
Thân chào cả nhà GPEX.!
Em có bài toán này mà chưa biết giải quyết ra sao, mong cả nhà giúp đỡ ạ

Em có 02 File:
File Danh Sach và File Data_Total (gần 100 sheet)
Ấn vào nút Run:
sẽ tự động Tách Sheet theo điều kiện Code Sold To (Cột B) File Danh Sach Map với điều kiện Range("C15") theo từng sheet ở File Data_Total, nếu thỏa điều kiện thì sẽ save File theo tên của cột Region (Nếu cùng chung 1 Region thì sẽ nằm Chung 1 File)

Em có làm File Demo Kết Quả và đính kèm ạ
Rất mong sợ giúp đỡ cua cả nhà, em chân thành cảm ơn ạ.

Trong khi chờ anh Snow hãy tham khảo code củ chuối này xem sao.

Mã:

Option Explicit


Sub NgocTuyen1995()

Dim i&, j&, t&, k&, Lr&, R&, LrWs&
Dim Arr(), KQ(), Res()
Dim Dic As Object, Fso As Object, Key
Dim Ws As Worksheet, Sh As Worksheet, Wb As Workbook
Dim File As Variant
Dim Path


With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual

Set Fso = CreateObject("Scripting.FileSystemObject")
Path = ActiveWorkbook.Path
Set Sh = Sheets("List")
Lr = Sh.Cells(Rows.Count, "A").End(xlUp).Row
Arr = Sh.Range("A2:F" & Lr).Value
R = UBound(Arr)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = VBA.Trim(Arr(i, 6))
        If Not Dic.Exists(Key) Then
            Dic(Key) = i
        Else
            Dic(Key) = Dic(Key) & "," & i
        End If
Next i
For Each File In Fso.GetFolder(Path).Files
        If File.Name Like "Data_total.xlsx" Then
            Set WbData = Workbooks.Open(File)
            Exit For
        End If
Next File

For Each Key In Dic.Keys
    If FileExists(Path & "\" & Key & ".xlsx") = False Then
        Set Wb = Workbooks.Add
        Wb.SaveAs Filename:=Path & "\" & Key & ".xlsx"
    End If
    S = Split(Dic(Key), ",")
        For i = 0 To UBound(S)
            For Each Ws In WbData.Sheets
                If Ws.[C15] Like Arr(S(i), 2) Then Ws.Copy Before:=Wb.Sheets(1): Exit For
            Next Ws
        Next i
            Wb.Save '        Wb.Close
    Next Key
Set Dic = Nothing
Set Fso = Nothing
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With
MsgBox "Done"
End Sub

Hãy test lại kỹ. Tôi chưa test kỹ
Lưu ý : đường dẫn của tôi có thể khác của bạn

BuiQuangThuan · 28/3/23

HUONGHCKT đã viết:
Hãy test lại kỹ. Tôi chưa test kỹ
Lưu ý : đường dẫn của tôi có thể khác của bạn

Kết quả mỗi file là 1 sheet hả chú

HUONGHCKT · 28/3/23

BuiQuangThuan đã viết:
Kết quả mỗi file là 1 sheet hả chú

Cảm ơn bạn đã xem bài có gì góp ý nhé. mỗi đơn vị (HCM, North, là 1 file, và mỗi file có thể có nhiều hơn 1 sheet). Trông cái tệp zip ấy có cả các file của bài trước nữa , tôi giải nén để luôn trong đó và không muốn xóa bỏ nữa.
Không biết có đúng ý của chủ thớt không? Cũng không test kỹ được. Thôi thì đã chót đăng lên rồi, chắc bạn ấy chờ code của anh snow.

snow25 · 29/3/23

ngoctuyen1995 đã viết:
Thân chào cả nhà GPEX.!
Em có bài toán này mà chưa biết giải quyết ra sao, mong cả nhà giúp đỡ ạ

Em có 02 File:
File Danh Sach và File Data_Total (gần 100 sheet)
Ấn vào nút Run:
sẽ tự động Tách Sheet theo điều kiện Code Sold To (Cột B) File Danh Sach Map với điều kiện Range("C15") theo từng sheet ở File Data_Total, nếu thỏa điều kiện thì sẽ save File theo tên của cột Region (Nếu cùng chung 1 Region thì sẽ nằm Chung 1 File)

Em có làm File Demo Kết Quả và đính kèm ạ
Rất mong sợ giúp đỡ cua cả nhà, em chân thành cảm ơn ạ.

Thử code nếu file đã có rồi nó sẽ thay bằng file mới.

Mã:

Sub tachfile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Dim i As Long, lr As Long, dic As Object, dk As String, duonglink As String, arr, kq, a As Long, wb As Workbook, sh As Worksheet
    Dim wb1 As Workbook, T(), b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("List")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("B2:F" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 1)
         For i = 1 To UBound(arr)
            dk = arr(i, 5)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = dk
            End If
            dk = arr(i, 1) & "#" & arr(i, 5)
            dic.Item(dk) = i
         Next i
            duonglink = .Range("j6").Value & "\Data_total.xlsx"
    End With
    Set wb = Workbooks.Open(duonglink)
        For i = 1 To a
            Erase T
            b = -1
            For Each sh In wb.Worksheets
                dk = sh.Range("C15").Value & "#" & kq(i, 1)
                If dic.exists(dk) Then
                   b = b + 1
                   ReDim Preserve T(0 To b)
                   T(b) = sh.Name
                End If
            Next
            If b > -1 Then
               wb.Sheets(T).Copy
               Set wb1 = ActiveWorkbook
               wb1.SaveAs Filename:=ThisWorkbook.Path & "\" & kq(i, 1) & ".xlsx"
               wb1.Close False
            End If
       Next i
   wb.Close False
   Set dic = Nothing
   Set wb = Nothing
   Set wb1 = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

ngoctuyen1995 · 29/3/23

HUONGHCKT đã viết:

Trong khi chờ anh Snow hãy tham khảo code củ chuối này xem sao.

Mã:

Option Explicit


Sub NgocTuyen1995()

Dim i&, j&, t&, k&, Lr&, R&, LrWs&
Dim Arr(), KQ(), Res()
Dim Dic As Object, Fso As Object, Key
Dim Ws As Worksheet, Sh As Worksheet, Wb As Workbook
Dim File As Variant
Dim Path


With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual

Set Fso = CreateObject("Scripting.FileSystemObject")
Path = ActiveWorkbook.Path
Set Sh = Sheets("List")
Lr = Sh.Cells(Rows.Count, "A").End(xlUp).Row
Arr = Sh.Range("A2:F" & Lr).Value
R = UBound(Arr)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = VBA.Trim(Arr(i, 6))
        If Not Dic.Exists(Key) Then
            Dic(Key) = i
        Else
            Dic(Key) = Dic(Key) & "," & i
        End If
Next i
For Each File In Fso.GetFolder(Path).Files
        If File.Name Like "Data_total.xlsx" Then
            Set WbData = Workbooks.Open(File)
            Exit For
        End If
Next File

For Each Key In Dic.Keys
    If FileExists(Path & "\" & Key & ".xlsx") = False Then
        Set Wb = Workbooks.Add
        Wb.SaveAs Filename:=Path & "\" & Key & ".xlsx"
    End If
    S = Split(Dic(Key), ",")
        For i = 0 To UBound(S)
            For Each Ws In WbData.Sheets
                If Ws.[C15] Like Arr(S(i), 2) Then Ws.Copy Before:=Wb.Sheets(1): Exit For
            Next Ws
        Next i
            Wb.Save '        Wb.Close
    Next Key
Set Dic = Nothing
Set Fso = Nothing
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With
MsgBox "Done"
End Sub

Hãy test lại kỹ. Tôi chưa test kỹ
Lưu ý : đường dẫn của tôi có thể khác của bạn

Em cảm ơn chị đã quan tâm đang giúp đỡ em ạ, nhờ chị góp ý mà em làm được bài tập này rồi ạ.

Bài đã được tự động gộp: 29/3/23

snow25 đã viết:

Thử code nếu file đã có rồi nó sẽ thay bằng file mới.

Mã:

Sub tachfile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Dim i As Long, lr As Long, dic As Object, dk As String, duonglink As String, arr, kq, a As Long, wb As Workbook, sh As Worksheet
    Dim wb1 As Workbook, T(), b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("List")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("B2:F" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 1)
         For i = 1 To UBound(arr)
            dk = arr(i, 5)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = dk
            End If
            dk = arr(i, 1) & "#" & arr(i, 5)
            dic.Item(dk) = i
         Next i
            duonglink = .Range("j6").Value & "\Data_total.xlsx"
    End With
    Set wb = Workbooks.Open(duonglink)
        For i = 1 To a
            Erase T
            b = -1
            For Each sh In wb.Worksheets
                dk = sh.Range("C15").Value & "#" & kq(i, 1)
                If dic.exists(dk) Then
                   b = b + 1
                   ReDim Preserve T(0 To b)
                   T(b) = sh.Name
                End If
            Next
            If b > -1 Then
               wb.Sheets(T).Copy
               Set wb1 = ActiveWorkbook
               wb1.SaveAs Filename:=ThisWorkbook.Path & "\" & kq(i, 1) & ".xlsx"
               wb1.Close False
            End If
       Next i
   wb.Close False
   Set dic = Nothing
   Set wb = Nothing
   Set wb1 = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Code nhanh và đúng ý em lắm ạ, nhờ anh mà em giải được bài toán này.. Em cảm ơn anh nha.
Chúc anh sức khỏe và thành công ạ..! Chúc diễn đàn ngày càng phát triển

xxxsongwww · 31/3/23

Dạ chào anh/chị
Em mới tìm hiểu VBA ạ.
Em có file exel gồm 2 loại sheet.
sheet 1 tên: quote 1 đến qoute 100 và sẽ hơn nữa.
sheet 2 có tên: thanh toán 1 đến 100 và hơn nữa ạ.
giờ em muốn xóa hết những sheet có tên là thanh toán thì phải làm sao ạ.

Ronaldinho7 · 31/3/23

xxxsongwww đã viết:
Dạ chào anh/chị
Em mới tìm hiểu VBA ạ.
Em có file exel gồm 2 loại sheet.
sheet 1 tên: quote 1 đến qoute 100 và sẽ hơn nữa.
sheet 2 có tên: thanh toán 1 đến 100 và hơn nữa ạ.
giờ em muốn xóa hết những sheet có tên là thanh toán thì phải làm sao ạ.

Bạn cho chạy vòng lặp qua các sheet
đụng sheet có tên thanh toán "nào đó" thì xóa nó đi nhá

cantl · 31/3/23

xxxsongwww · 31/3/23

Ronaldinho7 đã viết:
Bạn cho chạy vòng lặp qua các sheet
đụng sheet có tên thanh toán "nào đó" thì xóa nó đi nhá

Anh có thể code giúp em không ạ

Ronaldinho7 · 31/3/23

xxxsongwww đã viết:
Anh có thể code giúp em không ạ

Bạn gửi file lên đây, tôi không giúp được thì các thành viên khác sẽ giúp bạn nha.

xxxsongwww · 31/3/23

Ronaldinho7 đã viết:
Bạn gửi file lên đây, tôi không giúp được thì các thành viên khác sẽ giúp bạn nha.

Dạ file này em hông gửi được.Nó có giá của nhiều hàng nhạy cảm quá ạ.Em muốn xóa mấy cái sheet chi tiết thanh toán Detail á anh.nó có tới 150 sheet

BuiQuangThuan · 31/3/23

xxxsongwww đã viết:
Dạ file này em hông gửi được.Nó có giá của nhiều hàng nhạy cảm quá ạ.Em muốn xóa mấy cái sheet chi tiết thanh toán Detail á anh.nó có tới 150 sheet
View attachment 288263

Duyệt qua từng sheet. Sheet nào chứa cái chữ Detail thì xoá

xxxsongwww · 31/3/23

BuiQuangThuan đã viết:
Duyệt qua từng sheet. Sheet nào chứa cái chữ Detail thì xoá

bác code giúp em với được không ạ.EM gà mờ mới tìm hiểu VBA

Hoàng Tuấn 868 · 31/3/23

xxxsongwww đã viết:
Dạ chào anh/chị
Em mới tìm hiểu VBA ạ.
Em có file exel gồm 2 loại sheet.
sheet 1 tên: quote 1 đến qoute 100 và sẽ hơn nữa.
sheet 2 có tên: thanh toán 1 đến 100 và hơn nữa ạ.
giờ em muốn xóa hết những sheet có tên là thanh toán thì phải làm sao ạ.

xxxsongwww đã viết:
bác code giúp em với được không ạ.EM gà mờ mới tìm hiểu VBA

Mới tìm hiểu thì chịu khó tập viết code đi, vướng đâu hỏi đấy chứ thế này là nhờ từ đầu đến cuối rồi còn gì, đã thế file giả lập cũng không chịu gửi nữa thì.....

snow25 · 31/3/23

xxxsongwww đã viết:
Dạ file này em hông gửi được.Nó có giá của nhiều hàng nhạy cảm quá ạ.Em muốn xóa mấy cái sheet chi tiết thanh toán Detail á anh.nó có tới 150 sheet
View attachment 288263

Thử code này nhé.

Mã:

Sub xoasheet()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Dim sh As Worksheet
    For Each sh In ThisWorkbook.Worksheets
        If InStr(sh.Name, "thanh toán") Then
           sh.Delete
        End If
   Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Tách sheet và Save File theo điều kiện

Thành viên hoạt động

File đính kèm

Thành viên gạo cội

Thành viên hoạt động

Thành viên gạo cội

Thành viên hoạt động

Zalo 0986997214

File đính kèm

❆❆❆❆❆❆❆❆❆❆❆❆

Zalo 0986997214

Thành viên gạo cội

Thành viên hoạt động

Thành viên mới

Zl: 0707315985

!!! Giải thoát !!!

Thành viên mới

Zl: 0707315985

Thành viên mới

❆❆❆❆❆❆❆❆❆❆❆❆

Thành viên mới

Đăng ký hôm qua

Thành viên gạo cội