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

L
Đổi màu chữ trong VBA
Trả lời
9
Đọc
42
lvh1064
L
H
Hỗ trợ lấy danh sách dữ liệu thỏa mãn điều kiện
Trả lời
3
Đọc
115
DeTong
D
PhanTuHuong
Bàn về môn thể thao bóng bàn nào!
    • Thích
    • Yêu thích
    • Cười
2
Trả lời
38
Đọc
2K
lvh1064
L
salam
Ẩn ảnh sau chữ trong excel
Trả lời
11
Đọc
29K
itusbbk
itusbbk
nobita994
Trừ số lượng dần theo dòng khi quét Sumif tổng có tên sản phẩm bị trùng.
Trả lời
4
Đọc
109
nobita994
nobita994
F
  • Question
Nhờ tư vấn cách tạo QR trong Excel
Trả lời
7
Đọc
539
huuthang_bd
huuthang_bd
nguyen trung cuong
File chứa marco không mở được.
Trả lời
3
Đọc
99
hvnhpro
H
Tienvinh191
  • Question
Nhờ viết Code lấy dữ liệu tờ khai hải quan vào bảng tổng hợp
2
Trả lời
25
Đọc
2K
haott
H
CodyPham97
tạo biểu tượng thay thế nhấn đúp chuột
Trả lời
4
Đọc
92
phansythao
phansythao
dovanha1994
Giúp e tìm nguyên nhân sai và hướng dẫn e đọc file này với ạ
    • Phẫn nộ
Trả lời
4
Đọc
124
SA_DQ
SA_DQ
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
10
Đọc
556
20050911
20050911
N
Giúp sửa mã code
2
Trả lời
20
Đọc
461
Nguyễn Diêu Hiền
N
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11/2024
    • Thích
    • Yêu thích
Trả lời
1
Đọc
96
SA_DQ
SA_DQ
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
32
Đọc
872
VetMini
V
K
Nhờ mọi người hoàn thiện giúp công thức
Trả lời
4
Đọc
115
kiendt1973
K
P
Nhờ giúp đỡ hàm lọc dữ liệu theo tỉnh
Trả lời
10
Đọc
176
Parabol
P
H
Chúc mừng 20/11- ngày tôn vinh nhà giáo Việt Nam.
    • Thích
    • Yêu thích
Trả lời
0
Đọc
68
HUONGHCKT
H
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
7
Đọc
198
Ny Ny 2024
N
Nhật Anh 9x
  • Question
Tính tồn cuối kỳ luỹ kế cho nhiều mã
Trả lời
2
Đọc
108
Nhật Anh 9x
Nhật Anh 9x
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
2
Trả lời
20
Đọc
597
ptm0412
ptm0412
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

Back
Top Bottom