Xin CODE ghép dữ liệu từ nhiều file vào 1 file và Lọc theo địa chỉ (1 người xem)

[boyxin]

Chào các bác

Em có 1 vấn đề cần sự giúp đỡ từ các bác
Các file thành phần (6A.xls, 6B.xls, ... , 9C.xls) được trích ra từ chương trình quản lý HS (chương trình này xuất ra file với Font: .VnTime)

Em cần Lọc những HS trong 1 mớ các file được trích ra theo từng đội (xóm) trong cột địa chỉ

Nếu gộp chung lại thành 1 file thì dùng công thức có thể lọc được dễ dàng (để lẻ từng file như vầy mà dùng công thức để lọc thì em thấy không tiện)

Do Vậy: Nhờ các bác cho em xin đoạn code để có thể gheps nối các file đó thành 1 file (Dùng kiểu copy, paste em thấy nản quá). Khi ghép nối thì có chút xíu thay đổi

1. Cột STT: đánh từ 1 cho đến cuối của toàn bộ DS chú không dùng STT cũ của từng file
2. Chèn thêm cho em 1 cột với nội dung tên lớp chính là tên File thành phần (tên sheet trong file thành phần có thể hoặc không trùng với tên file)
3. Sau đó lọc và lấy 1 số cột như sheet OUTPUT (kết quả thay đổi theo drop-Down List) trong file Thống kê.

 

[ThuNghi]

1/ Thứ nhất là chép vào 1 Sh (có thể là tạm)
http://www.giaiphapexcel.com/forum/showthread.php?t=13885
2/ Từ Sh Tạm, tạo LocDuLieu theo Advance Filter. Boyxin làm được mà.
Nếu đã dùng VBA thì các name nên đặt = VBA, chớ dùng kiểu counta để xác định dòng cuối thì hơi phê.

 

[ThuNghi]

Gởi bạn 1 code "lâm nghiệp", tôi đã copy của mọi người và làm nên. Có thể edit lại nhưng chưa làm được.
1/ Chép tất cả các file TH và chi tiết vào 1 folder.
2/ Chép code sau vào 1 module
3/ Run
Code này sẽ duyệt qua các file trong folder <> "TKe PCGD" và chép vào input.
Còn out thì dễ rồi.

Option Explicit
Dim wbName As String, wName As String, myPath As String, ShName As String, iLop As String
Dim SourceWb As Workbook, TgtWb As Workbook
Dim i As Long, fR As Long, endR As Long, FolderName As String
Sub Tonghop()
With Application
       .DisplayAlerts = False
       .ScreenUpdating = False
       .Calculation = xlCalculationManual
End With
'***Xoa du lieu truoc khi appen
Sheets("input").Range("A3:AO65000").ClearContents
Set SourceWb = ThisWorkbook
myPath = ThisWorkbook.Path
FolderName = myPath
wName = Dir(FolderName & "\" & "*.xls")
'wbName = myPath & "\" & wbName
While wName <> ""
    If wName <> "TKe PCGD.xls" Then
        wbName = myPath & "\" & wName
        Workbooks.Open wbName
        Set TgtWb = Workbooks.Open(wbName)
        '*** Lay du lieu tu Sh
        ShName = TgtWb.ActiveSheet.Name
        iLop = Left(wName, Len(wName) - 4) 'ten lop
        If iLop <> ShName Then
            iLop = ShName
        End If
        With TgtWb.ActiveSheet
            endR = .Range("A65000").End(xlUp).Row 'dong cuoi cot so TT
            fR = SourceWb.Sheets("Input").Range("A65000").End(xlUp).Row + 1 'dong cuoi so TT +1
            SourceWb.Sheets("Input").Range("A" & fR & ":B" & endR + fR - 2).Value = .Range("A2:B" & endR).Value 'Lay ten
            SourceWb.Sheets("Input").Range("C" & fR & ":C" & endR + fR - 2).Value = iLop 'lay lop
            SourceWb.Sheets("Input").Range("D" & fR & ":AO" & endR + fR - 2).Value = .Range("C2:AN" & endR).Value 'Lay chi tiet
            TgtWb.Close
        End With
     End If
   wName = Dir
Wend
'Gan sott
Range("A3:A" & fR + endR - 2).FormulaR1C1 = "=ROW()-2"
Range("A3:A" & fR + endR - 2).Value = Range("A3:A" & fR + endR - 2).Value
Set SourceWb = Nothing
Set TgtWb = Nothing
MsgBox "Da lay du lieu xong" & Chr(13) & "Chuc vui ve!"
With Application
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

 

[boyxin]

Gởi bạn 1 code "lâm nghiệp", tôi đã copy của mọi người và làm nên. Có thể edit lại nhưng chưa làm được.
1/ Chép tất cả các file TH và chi tiết vào 1 folder.
2/ Chép code sau vào 1 module
3/ Run
Code này sẽ duyệt qua các file trong folder <> "TKe PCGD" và chép vào input.
Còn out thì dễ rồi.

Khi chạy thì báo lỗi

Debug thì báo lỗi tại đây

Workbooks.Open wbName

Hi
Phát hiện ra rồi, thiếu 1 dấu "\" tại

While wName <> ""
    If wName <> "TKe PCGD.xls" Then
(1)        wbName = myPath & "\" & wName
        Workbooks.Open wbName
        Set TgtWb = Workbooks.Open(wbName)

 

[ThuNghi]

Khi chạy thì báo lỗi

Debug thì báo lỗi tại đây

Workbooks.Open wbName

wName = Dir(FolderName & "\" & "*.xls")
'wbName = myPath & "\" & wbName
Có 1 dòng bỏ
Sao kỳ nhỉ, bạn xem thử file sau.

 

[ndu96081631]

Cái này bác Sa đã từng phát hiện... khi đưa code vào

... [ /php] thì những ký tự "\" tự động biến mất
Chính vì lẽ đó, ai sử dụng code có ký tự \ thì nên đưa vào [code] ... [ /code] hoặc [quote]...[/ QUOTE]
Hay tốt nhất là đưa luôn file đính kèm (mất công code, paste code vào file lại sai tùm lum)

 

[boyxin]

Hi
Có voi rồi lại muốn có 2 bà trưng. Có thể bổ sung thêm cho em

1. Trong khi tổng hợp, có thể định dạng cột ngày sinh cho đúng là dạng date (hiện tại có 1 số cell là text, 1 số lại là date)
2. Thêm 1 cột "Đội" và trước cột "địa chỉ" với nội dung là tách lấy phần số trong cột địa chỉ

Được như vậy thì phần còn lại (dùng công thức lọc theo yêu cầu OUTPUT đơn giản hơn rất nhiều)

hay là cho em luôn hai bà trưng luôn (Cho em xin code lọc luôn) Công thức với em thì OK rồi, nhưng Lọc bằng VBA thì em ... chịu

Cách lọc trong sheet OUTPUT:

1. Lấy những học sinh trong cùng 1 đội (trong down list)
2. Học sinh nào có năm sinh nhỏ ghi trước (nếu cùng tuổi thì ghi theo đơn vị lớp, lớp nhỏ ghi trước)

 

[ThuNghi]

Hi
Có voi rồi lại muốn có 2 bà trưng. Có thể bổ sung thêm cho em

1. Trong khi tổng hợp, có thể định dạng cột ngày sinh cho đúng là dạng date (hiện tại có 1 số cell là text, 1 số lại là date)
2. Thêm 1 cột "Đội" và trước cột "địa chỉ" với nội dung là tách lấy phần số trong cột địa chỉ

Được như vậy thì phần còn lại (dùng công thức lọc theo yêu cầu OUTPUT đơn giản hơn rất nhiều)

hay là cho em luôn hai bà trưng luôn (Cho em xin code lọc luôn) Công thức với em thì OK rồi, nhưng Lọc bằng VBA thì em ... chịu

Cách lọc trong sheet OUTPUT:

1. Lấy những học sinh trong cùng 1 đội (trong down list)
2. Học sinh nào có năm sinh nhỏ ghi trước (nếu cùng tuổi thì ghi theo đơn vị lớp, lớp nhỏ ghi trước)

Đã chỉnh ngày luôn và thêm 1 UDF tách số, cái này học của Thầy VoDa. Còn lại là "xào nấu".
Gia công thêm Code lọc luôn, cái From ... thì chưa hiểu. Còn bạn chỉnh lại CF nhé. Theo tôi thì không cần. Tôi thường làm là format Sh Output, dòng nào No Data thì hide.

 

[boyxin]

Đã chỉnh ngày luôn và thêm 1 UDF tách số, cái này học của Thầy VoDa. Còn lại là "xào nấu".
Gia công thêm Code lọc luôn, cái From ... thì chưa hiểu. Còn bạn chỉnh lại CF nhé. Theo tôi thì không cần. Tôi thường làm là format Sh Output, dòng nào No Data thì hide.

Rất cảm ơn các bác (đặc biệt là ThuNghi) đã tận tình giúp đỡ em trong vụ này.
Em còn một vài thắc mắc nhỏ. Mong được nói rõ hơn chút để em có thể học hỏi thêm

Em muốn ở cuối bảng có phần thống kê số lượng độ tuổi [year(hiện tại) - year(N.sinh)] 11, 12, ..., 17 và số nữ tương ứng thì thêm vào code như thế nào?

| THỐNG KÊ THEO ĐỘ TUỔI | | | | | | |
|11 tuổi|5|Trong đó:|Nữ =|2|tỷ lệ|40%|
|12 tuổi|7| | |3| |42.9%|
|13 tuổi|6| | |3| |50%|
|14 tuổi|10| | |4| |40%|
|15 tuổi|3| | |1| |33.3%|
|16 tuổi|4| | |2| |50%|
|17 tuổi|8| | |5| |62.5%|
| Tổng số | 43 | | | 20 | | 46.5% |

 

[ThuNghi]

Rất cảm ơn các bác (đặc biệt là ThuNghi) đã tận tình giúp đỡ em trong vụ này.
Em còn một vài thắc mắc nhỏ. Mong được nói rõ hơn chút để em có thể học hỏi thêm

Em muốn ở cuối bảng có phần thống kê số lượng độ tuổi [year(hiện tại) - year(N.sinh)] 11, 12, ..., 17 và số nữ tương ứng thì thêm vào code như thế nào?

| THỐNG KÊ THEO ĐỘ TUỔI | | | | | | |
|11 tuổi|5|Trong đó:|Nữ =|2|tỷ lệ|40%|
|12 tuổi|7| | |3| |42.9%|
|13 tuổi|6| | |3| |50%|
|14 tuổi|10| | |4| |40%|
|15 tuổi|3| | |1| |33.3%|
|16 tuổi|4| | |2| |50%|
|17 tuổi|8| | |5| |62.5%|
| Tổng số | 43 | | | 20 | | 46.5% |

Theo tôi cái bảng với 7 độ tuổi (luôn như vậy) này dùng công thức nhanh hơn, chớ VBA làm gì. VBA phải đặt thêm 7 *2 biến: 11TS, 11Nu, 12TS... thì quá tội mà dùng sumif thì không được, chỉ dùng sumproduct.=>dùng ct.
=SUMPRODUCT(--(YEAR(TODAY())-YEAR($E$5:$E$1000)+1=$N11))
Bạn vào code trong module2 sửa lại cái dòng này hộ.
Thay: (gần cuối Sub BaoCao) sửa dòng thông báo tại I2

Rows("4:4").EntireRow.Hidden = True
...
Set Data = Nothing

Thành

Rows("4:4").EntireRow.Hidden = True
Range("I2").Value = "( §éi " & Range("a2") & " Cã " & endR - 4 & " HS, trong ®ã: N÷ =" & j & " chiÕm tØ lÖ " & Round(j / (endR - 4) * 100, 2) & "% )"
ActiveWorkbook.Names("Criteria").Delete
ActiveWorkbook.Names("Extract").Delete
Set Data = Nothing

 

[boyxin]

Theo tôi cái bảng với 7 độ tuổi (luôn như vậy) này dùng công thức nhanh hơn, chớ VBA làm gì. VBA phải đặt thêm 7 *2 biến: 11TS, 11Nu, 12TS... thì quá tội mà dùng sumif thì không được, chỉ dùng sumproduct.=>dùng ct.
=SUMPRODUCT(--(YEAR(TODAY())-YEAR($E$5:$E$1000)+1=$N11))
Bạn vào code trong module2 sửa lại cái dòng này hộ.
Thay: (gần cuối Sub BaoCao) sửa dòng thông báo tại I2
Rows("4:4").EntireRow.Hidden = True
...
Set Data = Nothing
Thành
Rows("4:4").EntireRow.Hidden = True
Range("I2").Value = "( §éi " & Range("a2") & " Cã " & endR - 4 & " HS, trong ®ã: N÷ =" & j & " chiÕm tØ lÖ " & Round(j / (endR - 4) * 100, 2) & "% )"
ActiveWorkbook.Names("Criteria").Delete
ActiveWorkbook.Names("Extract").Delete
Set Data = Nothing

Nó không tự xóa hai name ("Criteria", "Extract").

Cảm ơn nhiều vì những điều góp ý chân thành

Nhưng đã dùng VBA mà vẫn phải có cell phụ, còn công thức thì không hay lắm. Các bác xem có thể làm thế nào để loại bỏ công thức trong bảng thống kê cuối danh sachs lọc

 

[ThuNghi]

Nó không tự xóa hai name ("Criteria", "Extract").

Cảm ơn nhiều vì những điều góp ý chân thành

Nhưng đã dùng VBA mà vẫn phải có cell phụ, còn công thức thì không hay lắm. Các bác xem có thể làm thế nào để loại bỏ công thức trong bảng thống kê cuối danh sachs lọc

Trước mắt dùng tạm công thức = VBA, tính dùng vòng lặp nếu gặp nsinh <> nsinh và sex <>"" thì TS=TS+1 nhưng đang làm biếng.