Tách file excel từ 1 file ra nhiều file

Liên hệ QC
U

uyvu

Thành viên mới
Tham gia
5/10/08
Bài viết
29
Được thích
0
Dear cả nhà
Tôi đã xem rất nhiều bài tách dữ liệu từ file excel nguồn ra nhiều file excel, tui có làm theo, nhưng vì yêu cầu tôi có khác so với mấy bài mẫu, nên tui vẫn bị bí --> do tự mày mò, ko có kiến thức VBA căn bản nên chỉ cần yêu cầu mình khác tý là thua
Nội dung của tôi nhờ cả nhà giúp:
- File Workflow, sheet "Coll Sources" chứa dữ liệu của tất cả nhân viên
- Hàng tháng tôi phải lọc cột "RO thu nợ" theo tên từng nhân viên, sau đó chép dữ liệu đó qua file của bạn nhân viên đó tương ứng (chép vào sheet "Data" của file từng bạn nhân viên)
- Tên file excel của mỗi bạn nhân viên được đặt theo cú pháp RO - [mã nhân viên] --> mã nhân viên này có ở sheet "Profile" của file workflow
- Ở cột "Ngày đến hạn" có công thức, khi chép qua file từng bạn nhân viên, vẫn giữ công thức, không phải chỉ chép value

Nhờ cả nhà giúp tôi, code VBA:
- Tự động lọc theo tên ở "RO thu nợ" chép vô đúng tên file theo mã nhân viên bạn đó, sẽ đi vòng lập đến tất cả nhân viên
- Nó sẽ lấy cú pháp đặt tên file excel của từng nhân viên để biết chép vô tương ướng file (Danh sách nhân viên ở sheet "Profile", cột mã nhân viên)
- Ở cột "Ngày đến hạn" khi chép qua vẫn giữ nguyên công thức


Thân chào cả nhà
 

File đính kèm

  • RO - chaupnu.xlsx
    26.2 KB · Đọc: 21
  • Workflow.xlsm
    729.1 KB · Đọc: 22
Sắp xếp theo thời gian sắp xếp theo bầu chọn
uyvu đã viết:
Dear cả nhà
Tôi đã xem rất nhiều bài tách dữ liệu từ file excel nguồn ra nhiều file excel, tui có làm theo, nhưng vì yêu cầu tôi có khác so với mấy bài mẫu, nên tui vẫn bị bí --> do tự mày mò, ko có kiến thức VBA căn bản nên chỉ cần yêu cầu mình khác tý là thua
Nội dung của tôi nhờ cả nhà giúp:
- File Workflow, sheet "Coll Sources" chứa dữ liệu của tất cả nhân viên
- Hàng tháng tôi phải lọc cột "RO thu nợ" theo tên từng nhân viên, sau đó chép dữ liệu đó qua file của bạn nhân viên đó tương ứng (chép vào sheet "Data" của file từng bạn nhân viên)
- Tên file excel của mỗi bạn nhân viên được đặt theo cú pháp RO - [mã nhân viên] --> mã nhân viên này có ở sheet "Profile" của file workflow
- Ở cột "Ngày đến hạn" có công thức, khi chép qua file từng bạn nhân viên, vẫn giữ công thức, không phải chỉ chép value

Nhờ cả nhà giúp tôi, code VBA:
- Tự động lọc theo tên ở "RO thu nợ" chép vô đúng tên file theo mã nhân viên bạn đó, sẽ đi vòng lập đến tất cả nhân viên
- Nó sẽ lấy cú pháp đặt tên file excel của từng nhân viên để biết chép vô tương ướng file (Danh sách nhân viên ở sheet "Profile", cột mã nhân viên)
- Ở cột "Ngày đến hạn" khi chép qua vẫn giữ nguyên công thức


Thân chào cả nhà
Nhấp chuột vào đây để mở rộng...
Bạn chép các file "RO - [mã nhân viên]" cho chung folder chứa file đính kèm code dưới rồi chạy thử nhé.
PHP: 
Sub zaq()
Dim I As Long, endR As Long, Arr, Path As String, NewWb, Wb As Workbook
Dim Rng As Range, Rng2 As Range
On Error Resume Next
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set Wb = ActiveWorkbook
    Path = ThisWorkbook.Path
        With Wb.Sheets("Coll Sources")
        
        endR = .Range("A650000").End(xlUp).Row
        Range("AB2:AB" & endR).Copy Range("AI2")
        Range("AI2:AI" & endR).RemoveDuplicates 1, xlNo
        
        Range("AJ2").Formula = "=""RO - "" & LEFT(AI2,FIND("" - "",AI2)-1)&"".xlsx"""
        Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).FillDown
        Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).Value = Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).Value
        
            Set Rng = .Range("A2", .[A65000].End(3)).Resize(, 28)
            Set Rng2 = .Range("A2", .[A65000].End(3)).Offset(, 32)
            Arr = .Range("AI2", .[AJ65000].End(3)).Value
                For I = 1 To UBound(Arr)
                        Rng.AutoFilter 28, Arr(I, 1)
                        Set NewWb = Workbooks.Open(Filename:=Path & "\" & Arr(I, 2)) '& ".xlsb")
                        .Range("A1").CurrentRegion.SpecialCells(12).Copy NewWb.Sheets("Data").Range("A1")
                        NewWb.Close True
                Next I
                    .Activate
                    .AutoFilterMode = False
        End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
MsgBox "Done"
End Sub
 

File đính kèm

  • Workflow_149957#3.xlsm
    710.9 KB · Đọc: 8
Upvote 0
quick87 đã viết:
Bạn chép các file "RO - [mã nhân viên]" cho chung folder chứa file đính kèm code dưới rồi chạy thử nhé.
PHP: 
Sub zaq()
Dim I As Long, endR As Long, Arr, Path As String, NewWb, Wb As Workbook
Dim Rng As Range, Rng2 As Range
On Error Resume Next
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set Wb = ActiveWorkbook
    Path = ThisWorkbook.Path
        With Wb.Sheets("Coll Sources")
       
        endR = .Range("A650000").End(xlUp).Row
        Range("AB2:AB" & endR).Copy Range("AI2")
        Range("AI2:AI" & endR).RemoveDuplicates 1, xlNo
       
        Range("AJ2").Formula = "=""RO - "" & LEFT(AI2,FIND("" - "",AI2)-1)&"".xlsx"""
        Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).FillDown
        Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).Value = Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).Value
       
            Set Rng = .Range("A2", .[A65000].End(3)).Resize(, 28)
            Set Rng2 = .Range("A2", .[A65000].End(3)).Offset(, 32)
            Arr = .Range("AI2", .[AJ65000].End(3)).Value
                For I = 1 To UBound(Arr)
                        Rng.AutoFilter 28, Arr(I, 1)
                        Set NewWb = Workbooks.Open(Filename:=Path & "\" & Arr(I, 2)) '& ".xlsb")
                        .Range("A1").CurrentRegion.SpecialCells(12).Copy NewWb.Sheets("Data").Range("A1")
                        NewWb.Close True
                Next I
                    .Activate
                    .AutoFilterMode = False
        End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Nhấp chuột vào đây để mở rộng...

Trước hết thanks bạn quick87

Mình đã chép chung Folder, nhưng không copy được
 
Upvote 0
Mình hiểu rồi, do code bạn viết là import vô file đuôi xlsx, còn file mình là xlsm --> nhờ bạn sửa giúp thành xlsm
Ngoài ra nhờ bạn giúp thêm tý nữa, dữ liệu gốc ở Sheet "Coll Sources" lúc đầu không có 2 cột "Ngày đến hạn" và "Ngày thu", do mình thêm vào --> nếu được, anh có thể giúp lúc import vào từng file nhân viên, nó tự động thêm 2 cột này luôn (không cần mình phải thêm vô Sheet "Coll Sources")

Lưu ý, ở cột "Ngày đến hạn" thêm luôn công thức "=IF(R2>=TODAY();"D";"")" --> không phải thêm giá trị value của nó

Cảm ơn anh rất nhiều
 
Upvote 0
uyvu đã viết:
Mình hiểu rồi, do code bạn viết là import vô file đuôi xlsx, còn file mình là xlsm --> nhờ bạn sửa giúp thành xlsm
Ngoài ra nhờ bạn giúp thêm tý nữa, dữ liệu gốc ở Sheet "Coll Sources" lúc đầu không có 2 cột "Ngày đến hạn" và "Ngày thu", do mình thêm vào --> nếu được, anh có thể giúp lúc import vào từng file nhân viên, nó tự động thêm 2 cột này luôn (không cần mình phải thêm vô Sheet "Coll Sources")

Lưu ý, ở cột "Ngày đến hạn" thêm luôn công thức "=IF(R2>=TODAY();"D";"")" --> không phải thêm giá trị value của nó

Cảm ơn anh rất nhiều
Nhấp chuột vào đây để mở rộng...
Bạn thử code dưới nhé:

PHP: 
Sub zaq()
Dim I As Long, endR As Long, Arr, Path As String, NewWb, Wb As Workbook
Dim Rng As Range, Rng2 As Range
On Error Resume Next
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set Wb = ActiveWorkbook
    Path = ThisWorkbook.Path
        With Wb.Sheets("Coll Sources")
        
        endR = .Range("A650000").End(xlUp).Row
        Range("AB2:AB" & endR).Copy Range("AI2")
        Range("AI2:AI" & endR).RemoveDuplicates 1, xlNo
        
        Range("AJ2").Formula = "=""RO - "" & LEFT(AI2,FIND("" - "",AI2)-1)&"".xlsm"""
        Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).FillDown
        Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).Value = Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).Value
        
            Set Rng = .Range("A2", .[A65000].End(3)).Resize(, 28)
            Set Rng2 = .Range("A2", .[A65000].End(3)).Offset(, 32)
            Arr = .Range("AI2", .[AJ65000].End(3)).Value
                For I = 1 To UBound(Arr)
                        Rng.AutoFilter 28, Arr(I, 1)
                        Set NewWb = Workbooks.Open(Filename:=Path & "\" & Arr(I, 2)) '& ".xlsb")
                        .Range("A1").CurrentRegion.SpecialCells(12).Copy NewWb.Sheets("Data").Range("A1")
                        With Sheets("Data")
                            .Range("AE1").Value = "Ngày " & ChrW(273) & ChrW(7871) & "n h" & ChrW(7841) & "n"
                            .Range("AE2").Formula = "=IF(R2>=TODAY(),""D"","""")"
                            .Range("AE2:AE" & Range("AB2").End(xlDown).Row).FillDown
                            .Range("AF1").Value = "Ngày thu"
                            .Range("R1:R" & Range("R2").End(xlDown).Row).Copy
                            .Range("AE1:AF" & Range("AB2").End(xlDown).Row).PasteSpecial Paste:=xlPasteFormats
                        End With
                        NewWb.Close True
                Next I
                    .Activate
                    .AutoFilterMode = False
                    .Columns("AI:AJ").Delete
        End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
MsgBox "Done"
End Sub
 

File đính kèm

  • Workflow_149957#7.xlsm
    711.5 KB · Đọc: 8
Upvote 0
Dear anh
Cảm ơn anh rất nhiều, nhưng vẫn còn bị 1 lỗi nhỏ
Dữ liệu import vô từng file nhân viên, hàm "=IF(R2>=TODAY();"D";"")" không có tác dụng, theo mình đang hiểu hàm ở cột "Ngày đến hạn" nó đang hiểu text.

Sau khi xem xét lại nhờ anh giúp thêm tý nữa, vì mình vẫn còn công đoạn, xuất dữ liệu từ hệ thống về, rồi mới chép toàn bộ dữ liệu vô Sheet "Coll Sources" --> vậy bây giờ mình không cần qua bước chép dữ liệu trung giang vô sheet "Coll Sources" nữa, mà chỉ cần tạo buttom ở file workflow. Khi nhấn vô nó sẽ hỏi chọn file dữ liệu excel cần import, sau đó chọn folder chứa các file nhân viên, chọn xong file thì tự nó import vô từ file nhân viên như trên (file workflow không cần sheet "Coll Sources" nữa)

Chân thành cảm ơn anh rất nhiều
 

File đính kèm

  • text.jpg
    text.jpg
    99.7 KB · Đọc: 5
Upvote 0
uyvu đã viết:
Dear anh
Cảm ơn anh rất nhiều, nhưng vẫn còn bị 1 lỗi nhỏ
Dữ liệu import vô từng file nhân viên, hàm "=IF(R2>=TODAY();"D";"")" không có tác dụng, theo mình đang hiểu hàm ở cột "Ngày đến hạn" nó đang hiểu text. (1)

Sau khi xem xét lại nhờ anh giúp thêm tý nữa, vì mình vẫn còn công đoạn, xuất dữ liệu từ hệ thống về, rồi mới chép toàn bộ dữ liệu vô Sheet "Coll Sources" --> vậy bây giờ mình không cần qua bước chép dữ liệu trung giang vô sheet "Coll Sources" nữa, mà chỉ cần tạo buttom ở file workflow. Khi nhấn vô nó sẽ hỏi chọn file dữ liệu excel cần import, sau đó chọn folder chứa các file nhân viên, chọn xong file thì tự nó import vô từ file nhân viên như trên (file workflow không cần sheet "Coll Sources" nữa) (2)

Chân thành cảm ơn anh rất nhiều
Nhấp chuột vào đây để mở rộng...
Mình sửa cho bạn vế (1):
PHP: 
Sub zaq()
Dim I As Long, endR As Long, Arr, Path As String, NewWb, Wb As Workbook
Dim Rng As Range, Rng2 As Range
On Error Resume Next
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set Wb = ActiveWorkbook
    Path = ThisWorkbook.Path
        With Wb.Sheets("Coll Sources")
       
        endR = .Range("A650000").End(xlUp).Row
        Range("AB2:AB" & endR).Copy Range("AI2")
        Range("AI2:AI" & endR).RemoveDuplicates 1, xlNo
       
        Range("AJ2").Formula = "=""RO - "" & LEFT(AI2,FIND("" - "",AI2)-1)&"".xlsm"""
        Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).FillDown
        Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).Value = Range("AJ2:AJ" & Range("AI2").End(xlDown).Row).Value
       
            Set Rng = .Range("A2", .[A65000].End(3)).Resize(, 28)
            Set Rng2 = .Range("A2", .[A65000].End(3)).Offset(, 32)
            Arr = .Range("AI2", .[AJ65000].End(3)).Value
                For I = 1 To UBound(Arr)
                        Rng.AutoFilter 28, Arr(I, 1)
                        Set NewWb = Workbooks.Open(Filename:=Path & "\" & Arr(I, 2)) '& ".xlsb")
                        .Range("A1").CurrentRegion.SpecialCells(12).Copy NewWb.Sheets("Data").Range("A1")
                        With Sheets("Data")
                            .Range("AE1").Value = "Ngày " & ChrW(273) & ChrW(7871) & "n h" & ChrW(7841) & "n"
                            .Range("AE2").Formula = "=IF(R2>=TODAY(),""D"","""")"
                            .Range("AE2:AE" & Range("AB2").End(xlDown).Row).FillDown
                            .Range("AF1").Value = "Ngày thu"
                            .Range("X1:X" & Range("X2").End(xlDown).Row).Copy
                            .Range("AE1:AE" & Range("AB2").End(xlDown).Row).PasteSpecial Paste:=xlPasteFormats
                            .Range("R1:R" & Range("R2").End(xlDown).Row).Copy
                            .Range("AF1:AF" & Range("AB2").End(xlDown).Row).PasteSpecial Paste:=xlPasteFormats
                        End With
                        NewWb.Close True
                Next I
                    .Activate
                    .AutoFilterMode = False
                    .Columns("AI:AJ").Delete
        End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Vế (2) thực sự chưa hình dung được, thấy hơi mâu thuẫn, bạn thử xuất file hệ thống rồi gửi lên đây xem sao nhé.
 
Upvote 0
Dear anh
Mình gửi anh file xuất từ hệ thống

Dữ liệu giống y như sheet "Coll Sources"
 

File đính kèm

  • Nợ 30-05.xls
    26 KB · Đọc: 5
Upvote 0
Mình đã hiểu rồi
- cột "Ngày đến hạn" giá trị trả về là chữ "D" --> cũng là text, mình thấy a sửa thành number, cũng không đúng lắm, anh sửa thành "general" đúng hơn
- Còn hàm ở cột "Ngày đến hạn" vẫn không dùng được vì cột R2 (Ngày thanh toán) xuất từ hệ thống xuống, nó đang là dạng text, mình so sánh với Today() nên có thể nó không hiểu --> anh sửa lại giúp định dạng cột "Ngày thanh toán" thành dạng date "dd/mm/yyyy"
 
Upvote 0
uyvu đã viết:
Mình đã hiểu rồi
- cột "Ngày đến hạn" giá trị trả về là chữ "D" --> cũng là text, mình thấy a sửa thành number, cũng không đúng lắm, anh sửa thành "general" đúng hơn
- Còn hàm ở cột "Ngày đến hạn" vẫn không dùng được vì cột R2 (Ngày thanh toán) xuất từ hệ thống xuống, nó đang là dạng text, mình so sánh với Today() nên có thể nó không hiểu --> anh sửa lại giúp định dạng cột "Ngày thanh toán" thành dạng date "dd/mm/yyyy"
Nhấp chuột vào đây để mở rộng...

Mình đã chỉnh được cái ngày rồi

Nhờ anh tạo buttom ở file workflow. Khi nhấn vô nó sẽ hỏi chọn file dữ liệu excel cần export, sau đó chọn folder chứa các file nhân viên, chọn xong thì tự nó import dữ liệu vô từng file nhân viên như trên (file workflow không cần sheet "Coll Sources" nữa)
 

File đính kèm

  • Workflow_149957#7.xlsm
    279.6 KB · Đọc: 7
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

A
Đếm dữ liệu với điều kiện
Trả lời
11
Đọc
85
DeTong
D
A
Excel thiếu dữ liệu
Trả lời
2
Đọc
48
Hoàng Tuấn 868
H
Maika8008
  • Question
Add-In .xlam trộn dữ liệu Excel vào Word
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
29
Đọc
2K
vu_tuan_manh_linh
vu_tuan_manh_linh
T
V/v tối ưu xử lý đoạn code
Trả lời
4
Đọc
145
huhumalu
H
H
  • Question
nhờ các bác viết mẫu cho em lệnh dùng checkbox để rút ngắn thời gian thao tác
Trả lời
16
Đọc
381
giaiphap
giaiphap
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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