Tách 1 file thành nhiều file có điều kiện

Liên hệ QC
saobekhonglac

saobekhonglac

Thành viên mới
Tham gia
1/11/08
Bài viết
1,565
Được thích
1,450
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ị.
 
saobekhonglac đã viết:
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ị.
Nhấp chuột vào đây để mở rộng...

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.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 & ".xlsx"
    End With
Next Sa
        Sheet1.Range("CK2:CK65000").ClearContents
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
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:
saobekhonglac đã viết:
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).
Cám ơn anh.
Nhấp chuột vào đây để mở rộng...

Bạn lấy lại code #2 đi. Tại tôi nhầm là xóa cột CK với CI (do gõ nhầm thô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...
 
saobekhonglac đã viết:
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,...)
Nhấp chuột vào đây để mở rộng...

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é...
 
Đú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...
 
saobekhonglac đã viết:
Đú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.
Nhấp chuột vào đây để mở rộng...

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

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....??)
 
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
 
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