Em cần hỗ trợ tách 1 sheet ra nhiều sheet (1 người xem)

[trinhminhvy]

Kính nhờ các bác hỗ trợ như sau ạ:
1. Tách dữ liệu mỗi Công ty ra 1 sheet - tên sheet là tên công ty.
2. Tự động đánh số thứ tự hóa đơn theo thứ tự ký hiệu hóa đơn và ngày tháng hóa đơn.
3. Tự động chèn 1 dòng tính tổng tiền hàng và tổng tiền thuế vào dòng cuối cùng của công ty đó.

Em đã mò được cách tách mỗi công ty ra 1 sheet bằng Pivot Table nhưng giao diện ko trực quan, ko thuận tiện cho việc in ấn. Mong các bác hỗ trợ dùng VBA ạ. Được hay không em cũng xin cảm ơn các bác đã đọc bài ạ.

Bài đã được tự động gộp: Thứ năm lúc 23:21

Em quên mất, các bác cho em xin Code để e có thể chủ động hơn ạ!

 

[DeTong]

hỗ trợ dùng VBA

Làm đại không biết đúng yêu cầu không...

 

[trinhminhvy]

Làm đại không biết đúng yêu cầu không...

Em cảm ơn bác, nhưng hiện tại chưa có dòng tổng tiền đối với từng công ty, chưa có cột số thứ tự hóa đơn của từng công ty ạ. bác xem giúp e nhé

 

[thuytrangbp28]

Cấu trúc sau khi tách giống cấu trúc ban đầu, vậy filter theo tên công ty luôn cho nhanh, cần gì tách cho mệt

 

[Hoàng Tuấn 868]

chưa có cột số thứ tự hóa đơn của từng công ty ạ.

Trong sheet mẫu cũng không có cột này thì phải.

 

[DeTong]

Thử thực nghiệm bằng thêm vài dòng sau...

Sub SplitTableByColumn()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim uniqueValues As Collection
    Dim cell As Range
    Dim destSheet As Worksheet
    Dim columnName As String
    Dim filteredTable As ListObject
    Dim i As Integer
    Dim lr As Long
    
    ' the table1 with all data
    Set ws = ThisWorkbook.Sheets("All")
    Set tbl = ws.ListObjects("table1")
    columnName = "Ten cong ty"

    'Xoa sheet cu
    DeleteAllExceptSpecificSheets
    
    ' Tao danh sach khong trung
    Set uniqueValues = New Collection
    On Error Resume Next
    For Each cell In tbl.ListColumns(columnName).DataBodyRange
        uniqueValues.Add cell.Value, CStr(cell.Value)
    Next cell
    On Error GoTo 0
    
    ' Vong lap tao danh sach
    For i = 1 To uniqueValues.Count
        ' Them sheet
        Set destSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        destSheet.Name = uniqueValues(i) ' Adjust the sheet naming convention as needed

        ' Filter the table
        tbl.Range.AutoFilter Field:=tbl.ListColumns(columnName).Index, Criteria1:=uniqueValues(i)

        ' Copy to the new sheet
        tbl.Range.SpecialCells(xlCellTypeVisible).Copy Destination:=destSheet.Cells(5, 2)
        lr = destSheet.Range("b1000").End(xlUp).Row + 2
        destSheet.Cells(lr, 2) = "Tong Cong"
        destSheet.Cells(lr, 2).Font.Italic = True
        
        destSheet.Cells(lr, 7) = "=sum(r[-6]c:r[-2]c)"
        destSheet.Cells(lr, 8) = "=sum(r[-6]c:r[-2]c)"
        destSheet.Cells(5, 2).CurrentRegion.EntireColumn.AutoFit
      
        ' Clear the filter
        ws.AutoFilterMode = False
    Next i
    
    ws.Activate
    End Sub

 

[Hoàng Tuấn 868]

Thử thực nghiệm bằng thêm vài dòng sau...

Khả năng là mong muốn của chủ bài sẽ chưa dừng ở đây, ví dụ: Để in thì còn phải tạo viền, bôi đậm dòng Tong Cong ...

 

[trinhminhvy]

Khả năng là mong muốn của chủ bài sẽ chưa dừng ở đây, ví dụ: Để in thì còn phải tạo viền, bôi đậm dòng Tong Cong ...

dạ đúng là như thế ạ, e cũng sợ đưa ra nhiều yêu cầu quá ko ai muốn giúp ạ. hihi

Bài đã được tự động gộp: Hôm qua, lúc 07:56

Cấu trúc sau khi tách giống cấu trúc ban đầu, vậy filter theo tên công ty luôn cho nhanh, cần gì tách cho mệt

đây là cái bảng mẫu đơn giản thôi, còn bảng gốc của em hàng chục nghìn dòng dữ liệu của hàng trăm công ty bác ạ.

Bài đã được tự động gộp: Hôm qua, lúc 08:00

Thử thực nghiệm bằng thêm vài dòng sau...

Sub SplitTableByColumn()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim uniqueValues As Collection
    Dim cell As Range
    Dim destSheet As Worksheet
    Dim columnName As String
    Dim filteredTable As ListObject
    Dim i As Integer
    Dim lr As Long
   
    ' the table1 with all data
    Set ws = ThisWorkbook.Sheets("All")
    Set tbl = ws.ListObjects("table1")
    columnName = "Ten cong ty"

    'Xoa sheet cu
    DeleteAllExceptSpecificSheets
   
    ' Tao danh sach khong trung
    Set uniqueValues = New Collection
    On Error Resume Next
    For Each cell In tbl.ListColumns(columnName).DataBodyRange
        uniqueValues.Add cell.Value, CStr(cell.Value)
    Next cell
    On Error GoTo 0
   
    ' Vong lap tao danh sach
    For i = 1 To uniqueValues.Count
        ' Them sheet
        Set destSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        destSheet.Name = uniqueValues(i) ' Adjust the sheet naming convention as needed

        ' Filter the table
        tbl.Range.AutoFilter Field:=tbl.ListColumns(columnName).Index, Criteria1:=uniqueValues(i)

        ' Copy to the new sheet
        tbl.Range.SpecialCells(xlCellTypeVisible).Copy Destination:=destSheet.Cells(5, 2)
        lr = destSheet.Range("b1000").End(xlUp).Row + 2
        destSheet.Cells(lr, 2) = "Tong Cong"
        destSheet.Cells(lr, 2).Font.Italic = True
       
        destSheet.Cells(lr, 7) = "=sum(r[-6]c:r[-2]c)"
        destSheet.Cells(lr, 8) = "=sum(r[-6]c:r[-2]c)"
        destSheet.Cells(5, 2).CurrentRegion.EntireColumn.AutoFit
     
        ' Clear the filter
        ws.AutoFilterMode = False
    Next i
   
    ws.Activate
    End Sub

báo lỗi này bác ạ, e insert vào file gốc của em.

 

[Hoàng Tuấn 868]

dạ đúng là như thế ạ, e cũng sợ đưa ra nhiều yêu cầu quá ko ai muốn giúp ạ. hihi

Nếu chủ bài không viết tắt thì đã được hỗ trợ xong lâu rồi.

 

[minhminh27]

Thay vì tách sheet sẽ gây dung lượng file tăng lên, hoặc có thể lại mất công đối chiếu lại các sheet chi tiết và số tổng khớp không (trường hợp này hay xảy ra lúc in ấn sheet chi tiết).
=> Bạn nghiên cứu phương án
1. Tạo sheet template dùng cho việc in và lấy các thông tin của 1 công ty vào đây.
2. Có nút bấm chọn tên công ty để lấy thông tin.
3. Có nút bấm in hàng loạt theo danh sách bạn có thể chọn

 

[trinhminhvy]

Nếu chủ bài không viết tắt thì đã được hỗ trợ xong lâu rồi.

Vậy e xin phép làm phiền mọi người thêm mấy nội dung nữa bác nhé. Mục 1 bác DETONG đã hỗ trợ em. Còn các mục sau ạ:
2. Tự động đánh số thứ tự hóa đơn theo thứ tự ký hiệu hóa đơn và ngày tháng hóa đơn.
3. Tự động chèn 1 dòng tính tổng tiền hàng và tổng tiền thuế vào dòng cuối cùng của công ty đó.
E xin bổ sung theo bảng kê dưới đây ạ.

 

[Hoàng Tuấn 868]

Vậy e xin phép làm phiền mọi người thêm mấy nội dung nữa bác nhé. Mục 1 bác DETONG đã hỗ trợ em. Còn các mục sau ạ:
2. Tự động đánh số thứ tự hóa đơn theo thứ tự ký hiệu hóa đơn và ngày tháng hóa đơn.
3. Tự động chèn 1 dòng tính tổng tiền hàng và tổng tiền thuế vào dòng cuối cùng của công ty đó.
E xin bổ sung theo bảng kê dưới đây ạ.

Bài của bạn đơn giản thôi, nhưng mình không hỗ trợ các trường hợp viết tắt. Thông cảm nhé.

 

[thuytrangbp28]

Bạn nói "có hàng trăm công ty", vậy bạn định tách ra hàng trăm sheet à??