Nhờ chỉ cách lọc dữ liệu từ excel và xuất ra nhiều file excel con khác (2 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)
V

vanminh888

Thành viên mới
Tham gia
20/12/11
Bài viết
19
Được thích
0
Nhờ mọi người giúp mình lọc từng BRANCH ra các file riêng với mỗi BRANCH ứng với tên "BANGTHONGBAO_IDBRANCH_TenBRANCH". Dưới là file mẫu của mình với ít dữ liệu demo, vì dữ liệu thật hơn ngàn dòng.

Mình đã nghĩ theo phương pháp lọc sau đó copy paste vào từng file riêng rồi, nhưng mình muốn một giải pháp khác là sau khi chạy sẽ từ sinh ra các file tương ứng với tên từng file đã định trước. Rất mong mọi người giúp đỡ và cho giải pháp. Xin cảm ơn.
 

File đính kèm

Bạn check file xem đúng ý bạn chưa nhé!
 

File đính kèm

Có ai giúp mình với, mình biết excel làm được mà.
 
quanluu1989 đã viết:
Cái này có rất nhiều bài, bạn tham khảo link này và sửa đổi cho phù hợp
http://www.giaiphapexcel.com/forum/...hiều-file-excel-mới-theo-điều-kiện-!&p=717132
Nhấp chuột vào đây để mở rộng...

Em làm theo các của bác được rồi. Hihi thank bác
Nhưng mà nó xuất được gần 70 file thì báo lỗi "Run error script" không thể truy cập đường dẫn trong ở C gì đó. !$@!!

Thêm 1 điều nữa là nếu mỗi file mới nó sét lại số thự tự từ 1 trở đi hết và đóng khung Table luôn thì hay biết mấy -\\/.
 
vanminh888 đã viết:
Em làm theo các của bác được rồi. Hihi thank bác
Nhưng mà nó xuất được gần 70 file thì báo lỗi "Run error script" không thể truy cập đường dẫn trong ở C gì đó. !$@!!

Thêm 1 điều nữa là nếu mỗi file mới nó sét lại số thự tự từ 1 trở đi hết và đóng khung Table luôn thì hay biết mấy -\\/.
Nhấp chuột vào đây để mở rộng...
thử kiểm tra xem sao. máy tôi chạy không bị lỗi , còn máy của bạn không biết à nha
Mã: 
Option Explicit
Sub Creat_newfile()
  Dim Sh As Worksheet, SrcRng As Range, CritRng As Range, endr As Long
  Dim Item
  On Error Resume Next
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
'  .................................................
  Set SrcRng = Sheet1.Range("A5").CurrentRegion
  If SrcRng Is Nothing Then Exit Sub
  Set CritRng = Sheet1.Range("H5") 'CÓ THE SUA H5 THANH COT A,B,C....
  Set CritRng = Intersect(CritRng.EntireColumn, SrcRng.Offset(1))
   If CritRng Is Nothing Then Exit Sub
'   .....................................................................
   With SrcRng
       For Each Item In UniqueList(CritRng)
            Sheets.Add.Name = Item
            .AutoFilter CritRng.Column - SrcRng.Column + 1, Item
            .SpecialCells(12).Copy Sheets(Item).Range("A5")
            .AutoFilter
           With Sheets(Item)
            endr = Range("A6").CurrentRegion.Rows.Count - 1
            .Move After:=Sheets(Sheets.Count)
            .Range("5:5").Font.Bold = True
            .Range("5:5").HorizontalAlignment = xlCenter
            .Range("A:j").EntireColumn.AutoFit
            .Range("A6").Resize(endr, 1).Value = Evaluate("ROW(R:R)")
            .Range("A6").CurrentRegion.Borders.LineStyle = 1
           End With
       Next
      .Parent.Activate
    End With
'    ......................................
For Each Sh In ThisWorkbook.Sheets
   If Sh.Name <> "BANGTHONGTIN" Then
    Sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sh.Name, 51
    ActiveWorkbook.Close
  End If
Next
'.................................................................
For Each Sh In ThisWorkbook.Sheets
    If Sh.Name <> "BANGTHONGTIN" Then Sh.Delete
  Next
'  .............................................................
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function UniqueList(Range As Range)
  Dim Clls As Range
  With CreateObject("Scripting.Dictionary")
    For Each Clls In Range
      If Not IsEmpty(Clls) And Not .Exists(Clls.Value) Then .Add Clls.Value, ""
    Next Clls
    UniqueList = .Keys
  End With
End Function
 

File đính kèm

hpkhuong đã viết:
Bạn làm theo code của ai? Lỗi gì có trời mới biết...

Thích thì chạy code này xem...
Mã: 
Option Explicit


Public Sub GPE()
Dim Dic As Object, Tmp As String, Arr, Pth, ShMain As Worksheet
Dim I As Long, WbMain As Workbook, Rng As Range, Sh As Worksheet, Stt As Range, K As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set WbMain = ThisWorkbook
Set ShMain = WbMain.Sheets("BANGTHONGTIN")
Set Rng = ShMain.Range("A1").CurrentRegion
Pth = ActiveWorkbook.Path
Arr = Rng.Value
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For I = 2 To UBound(Arr)
Tmp = Arr(I, 2)
    If Not .Exists(Tmp) Then
        .Add Tmp, ""
        With Workbooks.Add
            Set Sh = .Sheets(1)
            Sh.Name = ShMain.Name
            Rng.AutoFilter 2, Tmp
            ShMain.Range("A1", Rng).SpecialCells(12).Copy
            Sh.Range("A1").PasteSpecial xlPasteColumnWidths
            Sh.Range("A1").PasteSpecial xlPasteAll
            Rng.AutoFilter
            Set Stt = Sh.Range("A2", Sh.Range("A65000").End(3))
                K = Stt.Rows.Count
                Stt = Application.Evaluate("Row(1:" & K & ")")
                Sh.Range("A1").CurrentRegion.Borders.LineStyle = 1
                .Close True, Pth & "\BANGTHONGBAO_" & Arr(I, 8) & "_" & Tmp & ".xlsx"
        End With
    End If
Next I
End With
Set Dic = Nothing
ShMain.AutoFilterMode = False
Application.CutCopyMode = False
Application.SheetsInNewWorkbook = 3
MsgBox "Da Tach Xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Code của bác quá tuyệt vời bác ạ, hầu như đáp ứng hết yêu cầu của mình, tuy nhiên vẫn bị lỗi kia nên xuất thiếu 10 file, mình tìm hiểu nó bị ngặt khúc nào thì thấy đến cái đoạn tên "BRANCH" có dạng dấu / là bị lỗi.

VD: TT_VAB/CBA

Mình đổi tên xóa dấu / ở đoạn này thì nó chạy trơn tru đến cuối luôn. Cảm ơn bác rất nhiều. }}}}}
 
vanminh888 đã viết:
VD: TT_VAB/CBA

Mình đổi tên xóa dấu / ở đoạn này thì nó chạy trơn tru đến cuối luôn. Cảm ơn bác rất nhiều. }}}}}
Nhấp chuột vào đây để mở rộng...
Có 9 ký tự đặc biệt không được dùng để đặt tên cho tập tin. Bạn tham khảo mà tránh.
[FONT=&quot] \[/FONT]
[FONT=&quot] /[/FONT]
[FONT=&quot] :[/FONT]
[FONT=&quot] *[/FONT]
[FONT=&quot] ?[/FONT]
[FONT=&quot] "[/FONT]
[FONT=&quot] < [/FONT]
[FONT=&quot] > [/FONT]
[FONT=&quot] | [/FONT]
 
Lê Duy Thương đã viết:
thử kiểm tra xem sao. máy tôi chạy không bị lỗi , còn máy của bạn không biết à nha
Mã: 
Option Explicit
Sub Creat_newfile()
  Dim Sh As Worksheet, SrcRng As Range, CritRng As Range, endr As Long
  Dim Item
  On Error Resume Next
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
'  .................................................
  Set SrcRng = Sheet1.Range("A5").CurrentRegion
  If SrcRng Is Nothing Then Exit Sub
  Set CritRng = Sheet1.Range("H5") 'CÓ THE SUA H5 THANH COT A,B,C....
  Set CritRng = Intersect(CritRng.EntireColumn, SrcRng.Offset(1))
   If CritRng Is Nothing Then Exit Sub
'   .....................................................................
   With SrcRng
       For Each Item In UniqueList(CritRng)
            Sheets.Add.Name = Item
            .AutoFilter CritRng.Column - SrcRng.Column + 1, Item
            .SpecialCells(12).Copy Sheets(Item).Range("A5")
            .AutoFilter
           With Sheets(Item)
            endr = Range("A6").CurrentRegion.Rows.Count - 1
            .Move After:=Sheets(Sheets.Count)
            .Range("5:5").Font.Bold = True
            .Range("5:5").HorizontalAlignment = xlCenter
            .Range("A:j").EntireColumn.AutoFit
            .Range("A6").Resize(endr, 1).Value = Evaluate("ROW(R:R)")
            .Range("A6").CurrentRegion.Borders.LineStyle = 1
           End With
       Next
      .Parent.Activate
    End With
'    ......................................
For Each Sh In ThisWorkbook.Sheets
   If Sh.Name <> "BANGTHONGTIN" Then
    Sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sh.Name, 51
    ActiveWorkbook.Close
  End If
Next
'.................................................................
For Each Sh In ThisWorkbook.Sheets
    If Sh.Name <> "BANGTHONGTIN" Then Sh.Delete
  Next
'  .............................................................
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function UniqueList(Range As Range)
  Dim Clls As Range
  With CreateObject("Scripting.Dictionary")
    For Each Clls In Range
      If Not IsEmpty(Clls) And Not .Exists(Clls.Value) Then .Add Clls.Value, ""
    Next Clls
    UniqueList = .Keys
  End With
End Function
Nhấp chuột vào đây để mở rộng...

Code của bác cũng hay lắm, ko bị báo lỗi file nhưng khi xuất chỉ ra IDBRANCH mà ko theo BANGTHONGBAO_IDBRANCH_TenBRANCH. Cảm ơn bác nhiều. -\\/.
 
giangleloi đã viết:
Có 9 ký tự đặc biệt không được dùng để đặt tên cho tập tin. Bạn tham khảo mà tránh.
[FONT=&amp] \[/FONT]
[FONT=&amp] /[/FONT]
[FONT=&amp] :[/FONT]
[FONT=&amp] *[/FONT]
[FONT=&amp] ?[/FONT]
[FONT=&amp] "[/FONT]
[FONT=&amp] < [/FONT]
[FONT=&amp] > [/FONT]
[FONT=&amp] | [/FONT]
Nhấp chuột vào đây để mở rộng...

Do file xuất từ database ra bác ạ. Tks bác
 
vanminh888 đã viết:
Code của bác cũng hay lắm, ko bị báo lỗi file nhưng khi xuất chỉ ra IDBRANCH mà ko theo BANGTHONGBAO_IDBRANCH_TenBRANCH. Cảm ơn bác nhiều. -\\/.
Nhấp chuột vào đây để mở rộng...
THÌ THAY ĐOẠN NÀY ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & Sh.Name, 51
 THÀNH
ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & "BANG THONG BAO_" & Sh.Name & "_" & Sh.Range("B6"), 51
LÀ OK
Mã: 
Option Explicit
Sub Creat_newfile()
  Dim Sh As Worksheet, SrcRng As Range, CritRng As Range, endr As Long
  Dim Item
  On Error Resume Next
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
'  .................................................
  Set SrcRng = Sheet1.Range("A5").CurrentRegion
  If SrcRng Is Nothing Then Exit Sub
  Set CritRng = Sheet1.Range("H5") 'CÓ THE SUA H5 THANH COT A,B,C....
  Set CritRng = Intersect(CritRng.EntireColumn, SrcRng.Offset(1))
   If CritRng Is Nothing Then Exit Sub
'   .....................................................................
   With SrcRng
       For Each Item In UniqueList(CritRng)
            Sheets.Add.Name = Item
            .AutoFilter CritRng.Column - SrcRng.Column + 1, Item
            .SpecialCells(12).Copy Sheets(Item).Range("A5")
            .AutoFilter
           With Sheets(Item)
            endr = Range("A6").CurrentRegion.Rows.Count - 1
            .Move After:=Sheets(Sheets.Count)
            .Range("5:5").Font.Bold = True
            .Range("5:5").HorizontalAlignment = xlCenter
            .Range("A:j").EntireColumn.AutoFit
            .Range("A6").Resize(endr, 1).Value = Evaluate("ROW(R:R)")
            .Range("A6").CurrentRegion.Borders.LineStyle = 1
           End With
       Next
      .Parent.Activate
    End With
'    ......................................
For Each Sh In ThisWorkbook.Sheets
   If Sh.Name <> "BANGTHONGTIN" Then
    Sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "BANG THONG BAO_" & Sh.Name & "_" & Sh.Range("B6"), 51
    ActiveWorkbook.Close
  End If
Next
'.................................................................
For Each Sh In ThisWorkbook.Sheets
    If Sh.Name <> "BANGTHONGTIN" Then Sh.Delete
  Next
'  .............................................................
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function UniqueList(Range As Range)
  Dim Clls As Range
  With CreateObject("Scripting.Dictionary")
    For Each Clls In Range
      If Not IsEmpty(Clls) And Not .Exists(Clls.Value) Then .Add Clls.Value, ""
    Next Clls
    UniqueList = .Keys
  End With
End Function
 
Lần chỉnh sửa cuối:
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

G
Tách công thức ra khỏi chuỗi và tính kết quả? (2 người xem)
2
Trả lời
22
Đọc
2K
gobi
gobi
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
5
Đọc
110
VetMini
V
thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025 (1 người xem)
Trả lời
1
Đọc
42
Hoàng Tuấn 868
H
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
3
Đọc
148
Hoàng Tuấn 868
H
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
346
Đọc
31K
Vandat1607
V
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
15
Đọc
252
Hoangkhang01213
Hoangkhang01213
M
Xin giúp đỡ làm công thức điều kiện
Trả lời
2
Đọc
132
Hoangkhang01213
Hoangkhang01213
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
10
Đọc
5K
tle2003
T
C
  • Question Question
Xin hỏi Cách viết chú thích trong vba hiển thị tiếng việt
Trả lời
4
Đọc
181
ongke0711
ongke0711
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
28
Đọc
7K
Hoàng Tuấn 868
H
G
Xin Code xóa Module.
Trả lời
8
Đọc
300
huhumalu
H
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
3
Đọc
171
tle2003
T
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ (1 người xem)
2
Trả lời
22
Đọc
578
nguyendang95
N
S
Mở 2 cửa sổ riêng biệt
2
Trả lời
30
Đọc
23K
sakuraluu
S
F
Nhập dấu . (chấm) ở bàn phím phụ không tự chuyển thành dấu , (phẩy) (2 người xem)
Trả lời
16
Đọc
57K
tubaodn21
tubaodn21
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
21
Đọc
1K
PhanTuHuong
PhanTuHuong
L
Lỗi font khi convert từ pdf
Trả lời
3
Đọc
149
lamvu0677
L
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (1 người xem)
    • Thích
Trả lời
0
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
811
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA (1 người xem)
Trả lời
6
Đọc
246
Hoàng Tuấn 868
H
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
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom