Giúp mình tạo module copy từ mỗi sheet của file tổng hợp thành các file nhỏ (1 người xem)

leethanhbinhf · 11/3/13

Mình có file tổng hợp có đặc điểm : mỗi sheet là một môn học, danh sách sinh viên có thể thay đổi.
Mình muốn tạo một Module copy từ mỗi sheet của file tổng hợp thành nhiều file, mỗi file là một môn học riêng.
File tạo ra có mẫu sẵn, chỉ cần copy từ mỗi sheet danh sách và điểm thôi.

leethanhbinhf · 11/3/13

Mình đã tham khảo có code này hay "Tách 1 file n sheets thanh n files", nhưng nhờ sự chỉ giáo của cao thủ thêm:
- Chỉ tạo ra số lượng sheet nhất định. Ví dụ từ sheet 1 đến 6.
-Làm sao để copy một vùng dữ liệu nào đó, không copy toàn bộ sheet. Vùng copy chỉ cố định cột, hàng có thể thay đổi tùy theo lượng học sinh.
-Tên Sheet tạo ra có dạng : Tên file n sheet - Tên sheet.

Sub TaoFile()
On Error Resume Next
Application.ScreenUpdating = False: Application.EnableEvents = False
Application.DisplayAlerts = False: Application.Calculation = xlCalculationManual
Dim i As Long, MyName As Name
For i = 1 To Sheets.Count
Sheets(i).Copy
With ActiveWorkbook
With .Sheets(1)
.DrawingObjects.Delete
.Cells.Copy
.Cells.PasteSpecial 3
.Range("A1").Select
For Each MyName In .Names
MyName.Delete
Next
End With
'' With .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule
'' .DeleteLines 1, .CountOfLines
'' End With
.SaveAs Filename:=ThisWorkbook.Path & "\" & .Sheets(1).Name, FileFormat:=xlNormal
.Close
End With
Next
Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = True
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

Quang_Hải · 11/3/13

leethanhbinhf đã viết:
Mình có file tổng hợp có đặc điểm : mỗi sheet là một môn học, danh sách sinh viên có thể thay đổi.
Mình muốn tạo một Module copy từ mỗi sheet của file tổng hợp thành nhiều file, mỗi file là một môn học riêng.
File tạo ra có mẫu sẵn, chỉ cần copy từ mỗi sheet danh sách và điểm thôi.

Xem thử ý tưởng này thế nào. Giải nén ra 1 folder trước khi chay code.

leethanhbinhf · 11/3/13

Cảm ơn quanghai1969 nhiều nhé! Em đang chạy thử.

leethanhbinhf · 11/3/13

Anh quanghai đã làm rất gọn nhẹ. Nhưng phiền Anh quanh hai có thể sửa giùm em module copy tách riêng.
Tên sheet có thể thay đổi, chứ không cố định có tên "Môn" ban đầu.
Em muốn copy hàng loạt một số sheet chứ không copy từng cái và copy toàn bộ sheet.

Quang_Hải · 11/3/13

leethanhbinhf đã viết:
Anh quanghai đã làm rất gọn nhẹ. Nhưng phiền Anh quanh hai có thể sửa giùm em module copy tách riêng.
Tên sheet có thể thay đổi, chứ không cố định có tên "Môn" ban đầu.
Em muốn copy hàng loạt một số sheet chứ không copy từng cái và copy toàn bộ sheet.

Với file của bạn thì khả năng mình chỉ có tới đó thôi. Kiên nhẫn đợi sự trợ giúp của các anh chị khác nhé.

phieulang31 · 13/3/13

quanghai1969 đã viết:
Xem thử ý tưởng này thế nào. Giải nén ra 1 folder trước khi chay code.

Sao em chạy thử thì bị như thế này!

Mã:

 Sub copy_mon()Application.DisplayAlerts = False
Dim newfilename, sh
Set sh = Sheets("MAIN")
newfilename = sh.[B1] & sh.[B2] & sh.[B3] & sh.[B4]

With Sheets("Môn " & sh.[B2])
   .Range(.[B10], .[C65536].End(3).Offset(, 25)).Copy
End With

With Sheets("FORM")
   .[A3].PasteSpecial 3
   .Copy
   With ActiveWorkbook
      .ActiveSheet.Name = newfilename
[COLOR=#ff0000]      .SaveAs ThisWorkbook.Path & "\" & newfilename, 51 'co the thay so 51 thanh so 18[/COLOR]
      .Close
   End With
   .[A3:AA10000].ClearContents
End With
Application.DisplayAlerts = True
End Sub

Bị báo lỗi dòng màu đỏ! Em đã tạo folder mới như hướng dẫn..

Quang_Hải · 13/3/13

phieulang31 đã viết:
Sao em chạy thử thì bị như thế này!
...........
Bị báo lỗi dòng màu đỏ! Em đã tạo folder mới như hướng dẫn..

Nếu bạn đang sử dụng Office 2003 thì sửa số 51 thành 18

leethanhbinhf · 14/3/13

Sub copy_mon()
Application.DisplayAlerts = False
Dim newfilename, sh
Set sh = Sheets("MAIN")
newfilename = sh.[B1] & "_" & sh.[B2] & "_" & sh.[B3] & "_" & sh.[B4]
With Sheets("" & sh.[B2])
.Range(.[B10], .[C65536].End(3).Offset(, 25)).Copy
End With

With Sheets("FORM")
.[A3].PasteSpecial 3
.Copy
With ActiveWorkbook
.ActiveSheet.Name = newfilename
.SaveAs ThisWorkbook.Path & "\" & newfilename, 51 'co the thay so 51 thanh so 18
.Close
End With
.[A3:AA10000].ClearContents
End With
Application.DisplayAlerts = True
End Sub

Anh xem giùm, dòng đỏ hay bị báo lỗi. Em đã xóa thử cũng không ảnh hưởng nhiều, nhưng muốn hỏi để biết thêm.
Anh chỉ thêm nếu cột tên mà có ký tự 0 ( số không ) thì sẽ không copy những dòng đó. Cảm ơn Anh Quang Hải.

Quang_Hải · 14/3/13

leethanhbinhf đã viết:
Anh xem giùm, dòng đỏ hay bị báo lỗi. Em đã xóa thử cũng không ảnh hưởng nhiều, nhưng muốn hỏi để biết thêm.
Anh chỉ thêm nếu cột tên mà có ký tự 0 ( số không ) thì sẽ không copy những dòng đó. Cảm ơn Anh Quang Hải.

Dòng bạn tô màu đỏ là để đặt tên cho sheet trong file mới. Xóa thì sẽ không tạo tên cho sheet.

Cột tên sao lại có số 0? Không hiểu.

leethanhbinhf · 14/3/13

quanghai1969 đã viết:
Dòng bạn tô màu đỏ là để đặt tên cho sheet trong file mới. Xóa thì sẽ không tạo tên cho sheet.

Cột tên sao lại có số 0? Không hiểu.

Đặt tên sheet hay bị báo lỗi nhưng thing thoảng vẫn được.
Cột tên do đặt công thức nên hiện 0, và em muốn những dòng đó sẽ không copy trong file mới.

Hai Lúa Miền Tây · 14/3/13

Tách thử như sau:

Mã:

Sub TachFile()
    For Each sht In ThisWorkbook.Sheets
        sht.Copy
        Rows("1:7").Delete
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Left([Y3], 4) & " " & sht.Name & ".xls"
        ActiveWorkbook.Close True
    Next
    
End Sub

Quang_Hải · 14/3/13

leethanhbinhf đã viết:
Đặt tên sheet hay bị báo lỗi nhưng thing thoảng vẫn được.
Cột tên do đặt công thức nên hiện 0, và em muốn những dòng đó sẽ không copy trong file mới.

Chắc tại bạn tạo tiếng việt có dấu nên có lúc bị lỗi.
File bạn gởi chẳng thấy dòng nào bị trống hay có số 0 thì làm kiểu nào?

leethanhbinhf · 14/3/13

Gửi file

Gửi file nhờ các anh giúp đỡ.

leethanhbinhf · 14/3/13

Hai Lúa Miền Tây đã viết:
Tách thử như sau:

Mã:

Sub TachFile() For Each sht In ThisWorkbook.Sheets sht.Copy Rows("1:7").Delete ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Left([Y3], 4) & " " & sht.Name & ".xls" ActiveWorkbook.Close True Next End Sub

Anh có thể thêm một số chức năng như:
- Chọn số sheet cần tách. ( ví dụ chỉ tách sheet 1 và sheet 5 thôi )
- Tắt chế độ hide cột, hàng và chế độ filter trước khi copy
- Những hàng nào không có tên nhưng có ký tự nhận diện là 0 thì không copy ( thường nằm ở những dòng cuối )
- Tên file tách ra muốn thêm một số ký tự để dễ nhận diện như ( tên ngành : QTKD, học kỳ : I hoặc II ... ) để dễ nhận biết.
Cảm ơn Anh Hai Lúa Miền Tây rất nhiều.

phieulang31 · 14/3/13

Mình cũng có ý giống bạn nhưng khác hơn chút! Mà quan trọng là chưa làm được **~**

Mình dùng một file để quản lý và 2 folder: 1 folder là bảng tổng hợp điểm và 1 folder để chứa các file mới tách (trong folder này có chia các lớp) để nhiều file nhìn không khoa học lắm !$@!!

Ví dụ:

- Trong file quản lý mình chọn lớp 6A

- Tách các sheet trong file :tong hop diem cac lop\tong hop diem lop 6A.xls

- Lưu các file vừa tạo : diem cac mon\6A\6A Toan.. (tên file :lop&mon, folder 6A cũng được tự động tạo ra nếu chưa có)

Chỉ tách các môn học thôi nhé các bạn, không tách sheet "DSHS"!

Trong file "tong hop diem lop 6A.xls" mình dùng liên kết và các hàm không biết khi tách có bị lỗi không nữa.. +-+-+-+

CÁC BẠN, CÁC ANH CHỊ BỎ CHÚT THỜI GIAN NHÉ!! }}}}}

phieulang31 · 15/3/13

Cái này hình như không ai quan tâm nhỉ!! $-\\/.$

Hai Lúa Miền Tây · 16/3/13

leethanhbinhf đã viết:
Anh có thể thêm một số chức năng như:
- Chọn số sheet cần tách. ( ví dụ chỉ tách sheet 1 và sheet 5 thôi )
- Tắt chế độ hide cột, hàng và chế độ filter trước khi copy
- Những hàng nào không có tên nhưng có ký tự nhận diện là 0 thì không copy ( thường nằm ở những dòng cuối )
- Tên file tách ra muốn thêm một số ký tự để dễ nhận diện như ( tên ngành : QTKD, học kỳ : I hoặc II ... ) để dễ nhận biết.
Cảm ơn Anh Hai Lúa Miền Tây rất nhiều.

Vẽ 1 1 userform, trong userform có 1 listbox(listbox1), Textbox(txtHK), 2 commandbutton(cmdOK,cmdThoat)

Code sẽ như sau:

Mã:

Private Sub cmdOK_Click()
    Dim i As Integer
    If Len(txtHK) = 0 Then
        MsgBox "Ban phai nhap hoc ky", vbCritical
        txtHK.SetFocus
        Exit Sub
        Else
            With ListBox1
                For i = 0 To .ListCount - 1
                    If .Selected(i) = True Then
                        .ListIndex = i
                        Application.ScreenUpdating = False
                            Sheets(.List(i)).Copy
                             With Cells
                                  .EntireColumn.Hidden = False
                                  .EntireRow.Hidden = False
                                  .AutoFilter
                              End With
                              Rows("1:7").Delete
                              Rows(Range("C65000").End(xlUp).Row + 1 & ":65000").Delete
                              ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Left([Y3], 4) & " (Hoc ky " _
                                                                  & txtHK.Text & ") " & .List(i) & ".xls"
                              ActiveWorkbook.Close True
                        Application.ScreenUpdating = True
                        .Selected(i) = False
                    End If
                Next i
            End With
    End If
    txtHK = Null
    MsgBox "Da xuat xong file.", vbInformation
End Sub

Private Sub cmdThoat_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ListBox1.AddItem (ws.Name)
    Next ws
End Sub

Lưu ý giải nén và chạy file, file được xuất ra chung 1 folder

leethanhbinhf · 16/3/13

Hai Lúa Miền Tây đã viết:

Vẽ 1 1 userform, trong userform có 1 listbox(listbox1), Textbox(txtHK), 2 commandbutton(cmdOK,cmdThoat)

Code sẽ như sau:

Mã:

Private Sub cmdOK_Click()
    Dim i As Integer
    If Len(txtHK) = 0 Then
        MsgBox "Ban phai nhap hoc ky", vbCritical
        txtHK.SetFocus
        Exit Sub
        Else
            With ListBox1
                For i = 0 To .ListCount - 1
                    If .Selected(i) = True Then
                        .ListIndex = i
                        Application.ScreenUpdating = False
                            Sheets(.List(i)).Copy
                             With Cells
                                  .EntireColumn.Hidden = False
                                  .EntireRow.Hidden = False
                                  .AutoFilter
                              End With
                              Rows("1:7").Delete
                              Rows(Range("C65000").End(xlUp).Row + 1 & ":65000").Delete
                              ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Left([Y3], 4) & " (Hoc ky " _
                                                                  & txtHK.Text & ") " & .List(i) & ".xls"
                              ActiveWorkbook.Close True
                        Application.ScreenUpdating = True
                        .Selected(i) = False
                    End If
                Next i
            End With
    End If
    txtHK = Null
    MsgBox "Da xuat xong file.", vbInformation
End Sub

Private Sub cmdThoat_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ListBox1.AddItem (ws.Name)
    Next ws
End Sub

Lưu ý giải nén và chạy file, file được xuất ra chung 1 folder

Cảm ơn Anh rất nhiều. Anh làm form rất hay.
Anh chỉnh cho em một xíu nữa thôi:
- Không copy cột đầu tiên.
- Nếu trong cột tên hiện số 0 sẽ không copy dòng đó.

Cho em hỏi thêm, khi copy sheet main vào các file khác lại không chạy được?

TrungChinhs · 16/3/13

leethanhbinhf đã viết:
Cảm ơn Anh rất nhiều. Anh làm form rất hay.
Anh chỉnh cho em một xíu nữa thôi:
- Không copy cột đầu tiên.
- Nếu trong cột tên hiện số 0 sẽ không copy dòng đó.

Cho em hỏi thêm, khi copy sheet main vào các file khác lại không chạy được?

Code nằm trong Userform chứ không nằm trong sheet Main nên nó không chạy là phải rồi. Code của file này nằm gần trọn trong Userform (trừ code gọi Userform nằm trong Modules). Vì vậy muốn làm sang File khác bạn phải copy file này, Copy Sheet mới vào và xóa hết các sheet cũ đi trừ sheet Main rồi làm việc bình thường.

Hai Lúa Miền Tây · 21/3/13

Cách khác là Xuất cái form đó ra bên ngoài muốn cho nó vào file nào thì sau này cứ nhập nó vào thôi. (Import, export file ở thanh menu File, cửa sổ VBE)

leethanhbinhf · 23/3/13

leethanhbinhf đã viết:
Cảm ơn Anh rất nhiều. Anh làm form rất hay.
Anh chỉnh cho em một xíu nữa thôi:
- Không copy cột đầu tiên.
- Nếu trong cột tên hiện số 0 sẽ không copy dòng đó.

Cho em hỏi thêm, khi copy sheet main vào các file khác lại không chạy được?

Không anh chị em nào giúp vậy nhỉ?

Hai Lúa Miền Tây · 23/3/13

leethanhbinhf đã viết:
Không anh chị em nào giúp vậy nhỉ?

Bạn xem tạm ở file đính kèm nhé

donghung1512 · 20/3/15

Em coppy code sang file của em. Em gặp phải 1 số vấn đề nhờ các cao thủ giúp em.
1. Bỏ qua phần chọn sheet xuất file mà luôn chọn sheet Print để xuất. => Xuất ra file dạng "xls" nhưng khi em mở cứ có báo là định dạng file ko phù hợp.
2. Lưu file vào địa chỉ với điều kiện:
+ Nếu Trial No bắt đầu là TB ( ví dụ TB15-101) thì lưu thành TB15-101.xls và vào thư mục "TB"
+ Nếu Trial No bắt đầu là HP ( ví dụ HP15-101) thì lưu thành HP15-101.xls và vào thư mục "HP"
3. Tự động tạo HYPERLINK tới file theo Trial No. Ví dụ TB15-101 thì tạo HYPERLINK tới file TB15-101.xls

Giúp mình tạo module copy từ mỗi sheet của file tổng hợp thành các file nhỏ (1 người xem)

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

Thành viên mới

File đính kèm

Thành viên mới

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

File đính kèm

Thành viên mới

Thành viên mới

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

Thành viên mới

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

Thành viên mới

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

Thành viên mới

❆❆❆❆❆❆❆❆

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

Thành viên mới

File đính kèm

Thành viên mới

Thành viên mới

File đính kèm

Thành viên mới

❆❆❆❆❆❆❆❆

File đính kèm

Thành viên mới

Thành viên tích cực

❆❆❆❆❆❆❆❆

Thành viên mới

❆❆❆❆❆❆❆❆

File đính kèm

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

File đính kèm

Thời gian đếm ngược.