Tách 1 file thành nhiều file có điều kiện (3 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
saobekhonglac

saobekhonglac

Thành viên mới
Tham gia
1/11/08
Bài viết
1,565
Được thích
1,454
Giới tính
Nam
Chào anh/chị.

Em có file excel. Trong file có cột CI có 12 nhân viên. Nhờ anh/chị hướng dẫn giúp em cách tách file ra thành 12 file (mỗi nhân viên là 1 file, có thể lưu .xls hoặc xlsx nhưng vẫn giữ format cũ, có thể chọn đường dẫn lưu hoặc lưu mặc định vào file gốc cần tách, tên file lấy theo cột CJ, tên sheet lấy theo tên Sale trong cột CI).

Cám ơn anh/chị.
 
Anh xem lại giúp em khi xuất ra thì dữ liệu cột CI bị xóa hết (anh giữ lại dữ liệu cột CI giúp em). Khi xuất thì em thấy có phát sinh cột CK (tổng hợp lại danh sách 12 nhân viên, cột này em không cần thiết). Tên file cũng lấy theo cột CI chứ chưa lấy theo cột CJ (do 2 cột của em trùng tên nên nó đúng, nếu em đổi tên cột CJ thì không đúng).
Cám ơn anh.

hpkhuong đã viết:
Bạn chạy code sau:
Mã: 
Option Explicit


Sub GPE()
Dim Dic As Object, Tmp As String, Sa
Dim I As Long, J As Long, K As Long, ShSum As Worksheet
Dim Arr, dArr, Rng As Range, Sh
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Arr = Sheet1.Range(Sheet1.[CI2], Sheet1.[CI65000].End(3))
ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
    For I = 1 To UBound(Arr, 1)
    Tmp = Arr(I, 1)
        If Not .Exists(Tmp) Then
            K = K + 1
            .Add Tmp, K
            For J = 1 To UBound(Arr, 2)
                dArr(K, J) = Arr(I, 1)
            Next J
        End If
    Next I
End With
    Sheet1.Range("CK2").Resize(K, UBound(Arr, 2)) = dArr
On Error Resume Next
Set ShSum = ThisWorkbook.Sheets("Sum")
Set Rng = ShSum.UsedRange
ShSum.AutoFilterMode = False
For Each Sa In ShSum.Range("CK2:CK" & ShSum.[CK65000].End(3).Row)
    With Workbooks.Add
        Set Sh = .Sheets(1)
        Sh.Name = Sa
        Rng.AutoFilter 87, Sa
        ShSum.Range(ShSum.Range("A1"), Rng).SpecialCells(12).Copy
        Sh.Range("A1").PasteSpecial 8
        Sh.Range("A1").PasteSpecial
        Rng.AutoFilter
        .Close True, ThisWorkbook.Path & "\" & Sa & ".xlsx"
    End With
Next Sa
        Sheet1.Range("CK2:CK65000").ClearContents
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
Em để giống nhưng nếu đổi tên khác trong cột CJ thì nó vẫn lấy theo cột CI. (Nếu cột CJ của em là "Nguyễn Văn 1" ="1", "Nguyễn Văn 2" ="2",... Thì em muốn lưu tên file thành 1.xlsx, 2.xlsx,...)

hpkhuong đã viết:
Sao tôi thấy 2 cột có dữ liệu như nhau mà...
Nhấp chuột vào đây để mở rộng...
 
Đúng là đồng nhất, nếu CI = Nguyễn Văn 1 thì CJ = 1,..... Em muốn lưu tên file ngắn hơn để dễ nhìn và tiện theo dõi. Nhưng nếu khó quá thì em sữa cột CI lại cho gọn hơn cũng được, sẽ làm cột phụ thay thế cột CI.
Cám ơn anh nhiều.
hpkhuong đã viết:
Nhưng quan trọng là cột CI là chính đúng không, lọc theo cột này và copy dữ liệu ra theo tên Sale ở cột này.
Vậy thì giữa 2 cột CI và CJ phải tương đồng đúng không

Ví dụ Cột CI có 2 tên là Nguyễn Văn 1 (2 dòng) thì bên cột CJ cũng tương đương có 2 dòng đều là số 1 (đang nói trường hợp bạn ví dụ như trên).

Hay là có trường hợp cột CJ tại có 1 dòng là số 1 còn dòng còn lại là 1' (1 phẩy) chẳng hạn.

Tôi nghỉ là phải đồng nhất chứ...

Bạn cho biết rõ nhé...
Nhấp chuột vào đây để mở rộng...
 
Cám ơn anh trai nhiều.

hpkhuong đã viết:
Tất nhiên là về lý thì phải đương đồng rồi, nếu không tương đồng thì làm sao được...
Nhưng ở trên tôi cố tình hỏi để bạn nói như nào thôi...có hiểu vấn đề của chính mình hok thôi ah...kaka--=0--=0--=0
Vậy bạn lấy lại code sau:
Mã: 
Option Explicit


Sub GPE()
Dim Dic As Object, Tmp As String, Sa
Dim I As Long, J As Long, K As Long, ShSum As Worksheet
Dim Arr, dArr, Rng As Range, Sh
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Arr = Sheet1.Range(Sheet1.[CI2], Sheet1.[CI65000].End(3)).Resize(, 2)
ReDim dArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
    For I = 1 To UBound(Arr, 1)
    Tmp = Arr(I, 1) & "-" & Arr(I, 2)
        If Not .Exists(Tmp) Then
            K = K + 1
            .Add Tmp, K
            For J = 1 To UBound(Arr, 2)
                dArr(K, J) = Arr(I, J)
            Next J
        End If
    Next I
End With
    Sheet1.Range("CK2").Resize(K, UBound(Arr, 2)) = dArr
On Error Resume Next
Set ShSum = ThisWorkbook.Sheets("Sum")
Set Rng = ShSum.Range(ShSum.[A1], ShSum.[A65000].End(3)).Resize(, 88)
ShSum.AutoFilterMode = False
For Each Sa In ShSum.Range("CK2:CK" & ShSum.[CK65000].End(3).Row)
    With Workbooks.Add
        Set Sh = .Sheets(1)
        Sh.Name = Sa
        Rng.AutoFilter 87, Sa
        ShSum.Range(ShSum.Range("A1"), Rng).SpecialCells(12).Copy
        Sh.Range("A1").PasteSpecial 8
        Sh.Range("A1").PasteSpecial
        Rng.AutoFilter
        .Close True, ThisWorkbook.Path & "\" & Sa.Offset(, 1).Value & ".xlsx"
    End With
Next Sa
        Sheet1.Range("CK2:CL65000").ClearContents
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Nếu tôi làm bài này thì tôi sẽ dùng Dictionary + Advanced Filter + 1 vòng lập là đủ
Ai thử nghiên cứu xem. Tôi nghĩ code sẽ gọn hơn đấy
 
ndu96081631 đã viết:
Nếu tôi làm bài này thì tôi sẽ dùng Dictionary + Advanced Filter + 1 vòng lập là đủ
Ai thử nghiên cứu xem. Tôi nghĩ code sẽ gọn hơn đấy
Nhấp chuột vào đây để mở rộng...
em thấy cũng vậy chứ có gọn hơn gì đâu
Mã: 
Public Sub hello()
Dim dic As Object, r As Long, arr, lr As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set dic = CreateObject("Scripting.Dictionary")
With Sheet1
    lr = .[CJ65000].End(xlUp).Row
    arr = .Range("CJ2:CJ" & lr).Value
    .Copy , Sheet1
    For r = 1 To UBound(arr) Step 1
        If Len(arr(r, 1)) > 0 Then
            If Not dic.exists(arr(r, 1)) Then
                dic(arr(r, 1)) = 1
                .[ZZ2].Value = "=CJ2=""" & arr(r, 1) & """"
                .Range("A1:CJ" & lr).AdvancedFilter xlFilterCopy, .[ZZ1:ZZ2], ActiveSheet.[A1:CJ1], False
                ActiveSheet.Copy
                ActiveWorkbook.Worksheets(1).Name = .Name
                ActiveWorkbook.Close True, ThisWorkbook.Path & "\" & arr(r, 1) & ".xlsx"
            End If
        End If
    Next
    .[ZZ2].ClearContents
End With
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
doveandrose đã viết:
em thấy cũng vậy chứ có gọn hơn gì đâu
Nhấp chuột vào đây để mở rộng...

Gọn trong cách tiếp cận vấn đề! Tôi làm vầy:
Mã: 
Sub Main()
  Dim dic As Object, rngSrc As Range, wkbNew As Workbook
  Dim aIDs, n As Long
  Dim sFolder As String, FileName As String, SheetName As String
  sFolder = ThisWorkbook.Path & "\"
  Set rngSrc = ThisWorkbook.Worksheets("Sum").Range("A1:CJ10000")
  aIDs = rngSrc.Offset(1).Columns("CI:CJ").Value
  Set dic = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  rngSrc.Range("IV1").Value = rngSrc.Range("CI1").Value
  For n = 1 To UBound(aIDs, 1)
    If Len(aIDs(n, 1)) And Len(aIDs(n, 2)) Then
      SheetName = aIDs(n, 1):  FileName = aIDs(n, 2)
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, Empty
        Set wkbNew = Workbooks.Add(1)
        wkbNew.Sheets(1).Name = SheetName
        rngSrc.Range("IV2").Value = "'=" & SheetName
        rngSrc.AdvancedFilter 2, rngSrc.Range("IV1:IV2"), wkbNew.Sheets(1).Range("A1")
        wkbNew.SaveAs sFolder & FileName, xlOpenXMLWorkbook
        wkbNew.Close False
      End If
    End If
  Next
  Application.ScreenUpdating = True
  rngSrc.Range("IV1:IV2").ClearContents
  If dic.Count Then MsgBox "Ða luu " & dic.Count & " workbooks", , "THÔNG BÁO"
End Sub
Không phải "gọn" là "ngắn" đâu
------------------
Giải thuật đơn giản:
- Ta duyệt cột CI rồi add vào dic
- Cứ mỗi lần add được thứ gì đó vào dic, ta lại tạo 1 workbook mới, dùng công cụ AF lọc theo điều kiện (vừa add vào dic) sang workbook mới tạo (lọc luôn chứ không cần phải copy gì cả)
- Lưu workbook mới thành file
Vậy thôi
-----------------
Có 1 vài việc cần lưu ý:
- Do ta chỉ lưu mỗi file có 1 sheet nên khi tạo workbook, bằng cách nào đó ta phải tạo nó chỉ chứa 1 sheet thôi
- Code trên chưa bẫy lỗi, đúng ra ta phải xét tính hợp lệ của tên sheet (nếu không thì làm sao đặt tên).
- Cả tên file của phải lưu ý về tính hợp lệ này và còn vấn đề nếu file ta chuẩn bị lưu đã tồn tại trước đó thì sao? Cho lưu đè hay bỏ qua? Đó là lúc mà ta cho chạy code từ lần thứ 2 trở đi sẽ có vấn đề cần bàn..
vân.. vân...
 
hpkhuong đã viết:
Sao code trên của anh em chạy nó hok ra file nào hết vậy nhỉ?
(Hay vì lý do là mặc định khi new wbooks office trên máy em nó tự sinh ra 3 sheet là nó hok có tác dụng....??)
Nhấp chuột vào đây để mở rộng...
Mã: 
[COLOR=#000000][I]Workbooks.Add(1)[/I][/COLOR]
là lệnh tạo file mới có đúng 1 sheet và không liên quan đến thiết lập của người dùng , nó khác với
Mã: 
[COLOR=#000000][I]Workbooks.Add [/I][/COLOR]
bạn chạy code trên không ra kết quả thì cần xem lại ăn ở ra sao ? --=0--=0
 
Đúng rồi. Cột CJ sẽ ngắn gọn hơn cột CI (do lúc đầu em làm biếng mới copy cho giống CI cho nhanh, chứ thực tế thì CJ và CI khác nhau).

Cám ơn mấy anh nhiều.

hpkhuong đã viết:
Kaka. Đã tìm ra nguyên nhân...là vì sao:
Là vì do tác giả trên nói rằng tên sheet theo cột CI, tên File theo cột CJ. Mà thực tế thì cột CJ khác CI (có thể tác làm gọn lại cho dễ nhìn.). (Nhưng file trên #1 thì tác giả lại vô tình để nó trùng rùi.)
Cho nên khi lúc tôi viết code đã chỉnh cột CJ sang tên khác cột CI.
Và đã chạy code của bạn + của anh NDU trên file cũ nên nó hok có ra là đúng rồi.

Vậy thì: Code của bạn & của anh NDU chỉ chưa xét tới trường hợp là đặt tên file theo cột CJ chứ hok phải theo cột CI

Code của anh NDU thì đọc qua thấy anh set tên file là cột CJ nhưng nếu đổi tên tại cột CJ khác cột CI thì code lại chạy hok ra file nào hết như mình nói ở trên

Chắc chờ anh í vào xem lại! keke....
Nhấp chuột vào đây để mở rộng...
 
ndu96081631 đã viết:
Nói quá rồi đại ca ơi!
Chẳng thích ai gọi mình bằng thầy tí nào. Bạn bè hay anh em gì đó thấy thoải mái hơn
Nhấp chuột vào đây để mở rộng...
cảm ơn thầy đã nói ra suy nghĩ . Trong âm thầm em quan sát và học tập kiến thức của thầy nhiều hơn học bất cứ ai ở diễn đàn này nên luôn trân trọng và biết ơn để gọi chữ thầy . Nhưng nếu thầy đã nói vậy thì đây là lần cuối
từ nay sẽ là anh NDU thân mến . hi hi --=0
 
Anh NDU ơi.

Anh xem giúp em nếu em thay đổi tên ở cột CJ thì xuất ra nó chỉ ra đúng 1 tên nhóm 1 và 1 tên nhóm 2, những cái khác cùng tên nó sẽ bị đè lên nhau. Anh xem lại giúp em.

Anh sửa lại giúp em theo điều kiện sau:

1 code sẽ xuất dữ liệu sẽ xuất từ cột A đến CH và lấy tên file theo điều kiện cột CI (xuất 12 file: từ Nguyễn Văn 1 đến Nguyễn Văn 12).
1 code sẽ xuất dữ liệu sẽ xuất từ cột A đến CH và lấy tên file theo điều kiện cột CJ (xuất 2 file: file NHOM1 & NHOM2).

Cám ơn anh.

ndu96081631 đã viết:
Gọn trong cách tiếp cận vấn đề! Tôi làm vầy:
Mã: 
Sub Main()
  Dim dic As Object, rngSrc As Range, wkbNew As Workbook
  Dim aIDs, n As Long
  Dim sFolder As String, FileName As String, SheetName As String
  sFolder = ThisWorkbook.Path & "\"
  Set rngSrc = ThisWorkbook.Worksheets("Sum").Range("A1:CJ10000")
  aIDs = rngSrc.Offset(1).Columns("CI:CJ").Value
  Set dic = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  rngSrc.Range("IV1").Value = rngSrc.Range("CI1").Value
  For n = 1 To UBound(aIDs, 1)
    If Len(aIDs(n, 1)) * Len(aIDs(n, 2)) Then
      SheetName = aIDs(n, 1):  FileName = aIDs(n, 2)
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, Empty
        Set wkbNew = Workbooks.Add(1)
        wkbNew.Sheets(1).Name = SheetName
        rngSrc.Range("IV2").Value = "'=" & SheetName
        rngSrc.AdvancedFilter 2, rngSrc.Range("IV1:IV2"), wkbNew.Sheets(1).Range("A1")
        wkbNew.SaveAs sFolder & FileName, xlOpenXMLWorkbook
        wkbNew.Close False
      End If
    End If
  Next
  Application.ScreenUpdating = True
  rngSrc.Range("IV1:IV2").ClearContents
  If dic.Count Then MsgBox "Ða luu " & dic.Count & " workbooks", , "THÔNG BÁO"
End Sub
Không phải "gọn" là "ngắn" đâu
------------------
Giải thuật đơn giản:
- Ta duyệt cột CI rồi add vào dic
- Cứ mỗi lần add được thứ gì đó vào dic, ta lại tạo 1 workbook mới, dùng công cụ AF lọc theo điều kiện (vừa add vào dic) sang workbook mới tạo (lọc luôn chứ không cần phải copy gì cả)
- Lưu workbook mới thành file
Vậy thôi
-----------------
Có 1 vài việc cần lưu ý:
- Do ta chỉ lưu mỗi file có 1 sheet nên khi tạo workbook, bằng cách nào đó ta phải tạo nó chỉ chứa 1 sheet thôi
- Code trên chưa bẫy lỗi, đúng ra ta phải xét tính hợp lệ của tên sheet (nếu không thì làm sao đặt tên).
- Cả tên file của phải lưu ý về tính hợp lệ này và còn vấn đề nếu file ta chuẩn bị lưu đã tồn tại trước đó thì sao? Cho lưu đè hay bỏ qua? Đó là lúc mà ta cho chạy code từ lần thứ 2 trở đi sẽ có vấn đề cần bàn..
vân.. vân...
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

Lần chỉnh sửa cuối:
Có ai giúp mình với. .................

saobekhonglac đã viết:
Anh NDU ơi.

Anh xem giúp em nếu em thay đổi tên ở cột CJ thì xuất ra nó chỉ ra đúng 1 tên nhóm 1 và 1 tên nhóm 2, những cái khác cùng tên nó sẽ bị đè lên nhau. Anh xem lại giúp em.

Anh sửa lại giúp em theo điều kiện sau:

1 code sẽ xuất dữ liệu sẽ xuất từ cột A đến CH và lấy tên file theo điều kiện cột CI (xuất 12 file: từ Nguyễn Văn 1 đến Nguyễn Văn 12).
1 code sẽ xuất dữ liệu sẽ xuất từ cột A đến CH và lấy tên file theo điều kiện cột CJ (xuất 2 file: file NHOM1 & NHOM2).

Cám ơn anh.
Nhấp chuột vào đây để mở rộng...
 
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

ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
351
Đọc
32K
Tuanba1992
Tuanba1992
Anhhe
Em xin nhờ các cao nhân chỉ giáo em cách tính giờ làm việc của nhân viên với ạ Plz
Trả lời
0
Đọc
6
Anhhe
Anhhe
S
Chức năng refresh trong Pivot khi thêm bớt dòng
Trả lời
9
Đọc
122
ptm0412
ptm0412
O
XIN ANH CHỊ GIÚP ĐỠ HƯỚNG DẪN CHUYỂN VĂN BẢN THÀNH GIỌNG NÓI TRONG EXCEL Ạ.
Trả lời
2
Đọc
40
Duy Tùng 9x
Duy Tùng 9x
M
Mọi người giúp e với lỗi này là gì ạ
Trả lời
1
Đọc
42
SA_DQ
SA_DQ
E
Không cho người khác chỉnh sửa cố định dòng và cột trong google sheet
Trả lời
0
Đọc
42
Em khong biet
E
queluatb
  • Question Question
Lấy hóa đơn đầu vào cho hóa đơn đầu ra
Trả lời
5
Đọc
319
queluatb
queluatb
Vu_Thi_Xuan
Lỗi tham chiếu khi dùng Vlookup trong VBA (1 người xem)
Trả lời
9
Đọc
353
Vu_Thi_Xuan
Vu_Thi_Xuan
6
  • Question Question
vba tự động lấy dữ liệu từ etabs
Trả lời
2
Đọc
267
VetMini
V
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ
2
Trả lời
20
Đọc
712
198zxc
1
D
Nhờ anh chị xử lý giúp lỗi thực hiện lọc dữ liệu
Trả lời
2
Đọc
471
Hoàng Tuấn 868
H
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
50
Đọc
5K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
xin các cao thủ chỉ cách gỡ lỗi không khởi động được excel
Trả lời
4
Đọc
265
bs2
B
H
Chuyển file *xml hóa đơn điện tử sang excel
    • Thích
Trả lời
10
Đọc
474
htrunga2
H
D
Nhờ anh chị trên diễn đàn dùng hàm dò tìm dữ liệu trong bảng gửi kèm giúp ạ!
Trả lời
4
Đọc
148
dangvanphu.it
D
P
Phát âm thanh tiếng việt cho dữ liệu trong file excel
Trả lời
3
Đọc
185
PNQC
P
E
Giúp em tạo gợi ý trong combobox sau khi đã lọc danh sách duy nhất trong combobox đó
Trả lời
11
Đọc
3K
thepkun8x
T
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER
    • Thích
Trả lời
1
Đọc
4K
GPE-Trợ Lý
GPE-Trợ Lý
C
Tính tổng một khách hàng có nhiều mã hàng nhỏ
2
Trả lời
21
Đọc
417
Phuocam
Phuocam
G
Làm sao để sắp xếp nhiều cột và hàng theo abc vậy ạ ?
Trả lời
9
Đọc
271
Duy Tùng 9x
Duy Tùng 9x
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom