Nhờ anh chị giúp em khi nhập liệu tổng hợp thì sẽ tự động chạy qua Sheet 2A1, 2A2,...

thuanduc08 · 14/11/09

Nhờ các bác giúp em nhé. Thank nhiều.

SA_DQ · 15/11/09

Bạn xài thử macro sự kiện trong "Truong", như sau

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, Range("w8:W999")) Is Nothing Then
       Dim sName As String
   
       sName = Target.Value
       Sheets(sName).[A65500].End(xlUp).Offset(1).Resize(, 24).Value = _
          Cells(Target.Row, "A").Resize(, 24).Value
   End If
End Sub

(Chú í: Không nên có khoản trống trong tên trang tính & (nhắc thêm) chúng rất kị tiếng Việt & dài quá cũng không phải là hay!)

Chúc bạn như nguyện!

tam8678 · 15/11/09

HYen17 đã viết:
PHP:

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("w8:W999")) Is Nothing Then Dim sName As String sName = Target.Value Sheets(sName).[A65500].End(xlUp).Offset(1).Resize(, 24).Value = _ Cells(Target.Row, "A").Resize(, 24).Value End If End Sub

(Chú í: Không nên có khoản trống trong tên trang tính & (nhắc thêm) chúng rất kị tiếng Việt & dài quá cũng không phải là hay!)

Chúc bạn như nguyện!

---
Anh cho tôi hỏi thêm về vấn đề này, tôi muốn khi nhập xong (theo file trên là từ W8:W43), lúc này mới cho chạy code thì mới phân đồng loạt về các lớp và code được viết như thế nào?.
Mong anh hướng dẫn.

ndu96081631 · 15/11/09

HYen17 đã viết:
PHP:

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("w8:W999")) Is Nothing Then Dim sName As String sName = Target.Value Sheets(sName).[A65500].End(xlUp).Offset(1).Resize(, 24).Value = _ Cells(Target.Row, "A").Resize(, 24).Value End If End Sub

(Chú í: Không nên có khoản trống trong tên trang tính & (nhắc thêm) chúng rất kị tiếng Việt & dài quá cũng không phải là hay!)

Chúc bạn như nguyện!

Hình như sư phụ thiếu phần bẩy lổi: Sheet không tồn tại
------------------------------------

tam8678 đã viết:
---
Anh cho tôi hỏi thêm về vấn đề này, tôi muốn khi nhập xong (theo file trên là từ W8:W43), lúc này mới cho chạy code thì mới phân đồng loạt về các lớp và code được viết như thế nào?.
Mong anh hướng dẫn.

Nếu anh muốn làm theo cách này thì càng dể ---> Dùng AutoFilter lọc theo lớp, được lớp nào ta copy sang sheet của lớp ấy luôn (đương nhiên là làm bằng code)
------------------------------------
Tuy nhiên bài này em nghĩ dùng PivotTable là nhanh gọn nhất ---> Khỏi công thức, khỏi code luôn
Xem file đính kèm

tam8678 · 15/11/09

ndu96081631 đã viết:
Em nghĩ code phải cải tiến thêm sư phụ à:
- Nếu sheet tồn tại ---> Mang dử liệu sang sheet ấy
- Nếu sheet không tồn tại ---> Add thêm sheet (và đặt tên), sau đó mới mang dử liệu sang

---
Nếu làm được như thế này thì tuyệt vời
---

Nếu anh muốn làm theo cách này thì càng dể ---> Dùng AutoFilter lọc theo lớp, được lớp nào ta copy sang sheet của lớp ấy luôn (đương nhiên là làm bằng code)

---
Chổ này anh không hiểu?:
1> Code lọc dựa vào điều kiện, ví dụ chọn A1 => lọc theo A1? (không mong muốn như thế)
2> Code lọc dựa vào điều kiện phát sinh (Có bao nhiêu trích bấy nhiêu), :-=

Đây mới đúng là code anh cần. Việc này theo anh thì chắc khó, anh có ý vận dụng vào kế toán.
---
TO: NDU, đúng yêu cầu rồi :-=

, anh sẽ vận dụng, nếu có khó khăn mong chú hướng dẫn giúp cho.

ndu96081631 · 15/11/09

tam8678 đã viết:
---
Nếu làm được như thế này thì tuyệt vời
---

---
Chổ này anh không hiểu?:
1> Code lọc dựa vào điều kiện, ví dụ chọn A1 => lọc theo A1? (không mong muốn như thế)
2> Code lọc dựa vào điều kiện phát sinh (Có bao nhiêu trích bấy nhiêu), Đây mới đúng là code anh cần. Việc này theo anh thì chắc khó, anh có ý vận dụng vào kế toán.

Anh xem code này:
1> Kiểm tra sự tồn tại của 1 sheet

PHP:

Private Function SheetExist(WorkSheetName As String) As Boolean
  On Error Resume Next
  SheetExist = Not Sheets(WorkSheetName) Is Nothing
End Function

2> Tạo list duy nhất của tên lơp

PHP:

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, ""
      End If
    Next Clls
    UniqueList = .Keys
  End With
End Function

3> Code chính dùng để lọc dử liệu sang các sheet

PHP:

Sub Loc()
  Dim Sh As Worksheet, Clls As Range, Item
  Application.ScreenUpdating = False
  On Error Resume Next
  Set Sh = Sheets("DS toan truong")
  With Sh.Range(Sh.[A7], Sh.[W65536].End(xlUp))
    For Each Item In UniqueList(.Offset(1, 22).Resize(, 1))
      If Not SheetExist(CStr(Item)) Then Sheets.Add.Name = Item
      Sheets(Item).Range("A:W").ClearContents
      .AutoFilter 23, Item
      .SpecialCells(12).Copy: Sheets(Item).Range("A1").PasteSpecial 3
      .AutoFilter
      With Sheets(Item)
        .Move After:=Sheets(Sheets.Count)
        .Range("1:1").Font.Bold = True
        .Range("1:1").HorizontalAlignment = xlCenter
        .Range("A:W").EntireColumn.AutoFit
        .Range("C2:C1000").NumberFormat = "dd/mm/yyyy"
        .Range(.Range("A2"), .Range("A65536").End(xlUp)).Value = Evaluate("ROW(R:R)")
      End With
    Next
    .Parent.Activate
  End With
  Application.ScreenUpdating = True
End Sub

Xem file đính kèm này ---> Dù sheet có tồn tại hay không thì nó vẫn cứ lọc tuốt
Anh chạy code thử v2 xem còn chổ nào cần phải cải tiến hay không

tam8678 · 15/11/09

ndu96081631 đã viết:
Anh xem code này:
3> Code chính dùng để lọc dử liệu sang các sheet
Sheets(Item).Range("A:W").ClearContents
Xem file đính kèm này ---> Dù sheet có tồn tại hay không thì nó vẫn cứ lọc tuốt
Anh chạy code thử v2 xem còn chổ nào cần phải cải tiến hay không

---
Code tốt lắm rồi, chú có thể thêm trong trường hợp này được không?, xóa sạch dữ liệu tất cả các sheet (đương nhiên không xóa sheet Data) trước khi chạy code nhằm tránh trường hợp...theo ví dụ trên là nhập lớp: nhập lớp 2A3 vào lớp 2A1 => lớp 2A1: đúng (vì có code trên), lớp 2A3: dữ liệu vẫn còn (rỗng mới đúng, nếu phức tạp thì không cần xóa sheet 2A3). Không biết chú có đồng ý không?
--=0

havietchuong · 15/11/09

Tôi mới làm quen với một phần công thức mảng, xin có ý kiến một chút thế này.
Cột A, bạn thuanduc08 cho theo cột B. Cho nên tôi có ý từ cột B.
-Copy cả sheet (DS toan truong) sang sheet (2A1).
-Tô khối ô B8:W43 xong bấm dấu =
-Trở về sheet (DS toan truong) cũng tô khối ô B8:W43.
-Bấm tổ hợp phím: Ctrl+Shift+Enter. Như thế, tất cả những dữ liệu nào khi nhập vào sheet (DS toan truong) đều được có trong sheet (2A1).
Mời các bạn tham khảo.

sonluan77 · 15/11/09

Cho em hỏi chút xíu. Em muốn lọc ra danh sách các lớp 2A1; 2A2; 2A3 ...(có thể còn nhiều lớp khác nữa) dựa vào cột lớp (cột W).
Yêu cầu sau khi lọc xong thì tên sheet được thay đổi bằng tên lớp. Em cảm ơn trước.

concogia · 15/11/09

thuanduc08 đã viết:
Nhờ các bác giúp em nhé. Thank nhiều.

Các cao thủ lại phức tạp hóa vấn đề "zồi" bài này thật ra chỉ cần thêm một côt phụ rồi dùng VLOOKUP sẽ dò ra hết danh sách từng lớp ( chưa xếp theo thứ tự). Ở trường mình có 34 lớp nhưng chia làm 4 khối, danh sách từng khối mình dùng công thức lôi một cái roẹt là ra hết . Còn nếu muốn có danh sách theo thứ tự thì dùng VBA nhưng đơn giản thôi : dùng advanced filter sau đó sort rồi chép vào sheet lớp là xong
Thân

tam8678 · 15/11/09

sonluan77 đã viết:
Cho em hỏi chút xíu. Em muốn lọc ra danh sách các lớp 2A1; 2A2; 2A3 ...(có thể còn nhiều lớp khác nữa) dựa vào cột lớp (cột W).
Yêu cầu sau khi lọc xong thì tên sheet được thay đổi bằng tên lớp. Em cảm ơn trước.

---
Bạn có tets bài 6 của chú NDU chưa? Theo tôi nghĩ đúng sự mong đợi của bạn.

thuanduc08 · 15/11/09

Cảm ơn các bác đã quan tâm đến vấn đề này. Thật tuyệt với bài của bác ndu96081... Em không hiểu lắm về VBA nhưng em thấy hay quá. Bác Ndu96081... cho em hỏi thêm chút nếu muốn lọc thêm một số lớp nữa như 1A1, ...... thì phải bổ sung như thế nào? Nếu sửa dữ liệu ở sheet gốc thì có cách nào để dữ liệu ở các sheet được lọc kia thay đổi không?

tam8678 · 15/11/09

thuanduc08 đã viết:
Cảm ơn các bác đã quan tâm đến vấn đề này. Thật tuyệt với bài của bác ndu96081... Em không hiểu lắm về VBA nhưng em thấy hay quá. Bác Ndu96081... cho em hỏi thêm chút nếu muốn lọc thêm một số lớp nữa như 1A1, ...... thì phải bổ sung như thế nào? Nếu sửa dữ liệu ở sheet gốc thì có cách nào để dữ liệu ở các sheet được lọc kia thay đổi không?

---
Bạn cứ lấy 1 học sinh lớp 2A1 sửa lại thành lớp 1A1 => chạy code, sẽ thấy ngay được vấn đề.

sonluan77 · 15/11/09

tam8678 đã viết:
---
Bạn cứ lấy 1 học sinh lớp 2A1 sửa lại thành lớp 1A1 => chạy code, sẽ thấy ngay được vấn đề.

Dốt thật tôi đã Test (#6) và đã thay đổi tên lớp hoặc xoá trắng ô chứa tên lớp và LỌC nhưng các sheet tạo ra đều trắng tinh kô có DL gì cả mà tên sheet vẫn lẫn lượt từ 1 đến hết.
Các bạn giải thích chi tiết giùm

sealand · 16/11/09

Mình tham gia 1 cách viết 1 hàm nhỏ để tìm dòng tương ứng để điền sau đó dùng công thức. Như vậy phù hợp hơn với các bạn còn hạn chế VBA. Nếu chậm thì tạm tắt calculation khi nhập liệu (Dùng công thức thì thường vậy, nhưng sau này cải tiến hàm hay dùng cột phụ bên sheet toàn trường thì sẽ nhanh hơn). Lưu ý kẻ bảng tự động bằng Cond. Format nên không kẻ nữa

Mã:

Function dchi(lop As String, Tt As Integer, rng As Range) As Long
k = 1
For i = 1 To rng.Cells.Count
If UCase(rng.Cells(i).Value) = UCase(lop) Then
If k = Tt Then
dchi = rng.Cells(i).Row - 1
Exit Function
Else
k = k + 1
End If
End If
Next
End Function

tam8678 · 16/11/09

sonluan77 đã viết:
Dốt thật tôi đã Test (#6) và đã thay đổi tên lớp hoặc xoá trắng ô chứa tên lớp và LỌC nhưng các sheet tạo ra đều trắng tinh kô có DL gì cả mà tên sheet vẫn lẫn lượt từ 1 đến hết.
Các bạn giải thích chi tiết giùm

---
Giải thích như thế nào hả quý bạn? Chỉ việc làm tuần tự ( tải bài #6):
1> STT1- Học sinh Bùi Trần Mai Anh- Lớp 2A1 => Sửa lại: lớp 1A1
2> Click: LOC
3> Nhận kết quả :-=

hoặc xoá trắng ô chứa tên lớp

---
Không đúng theo câu hỏi ban đầu của bạn và cũng không thể có trường hợp rỗng (xóa trắng) vì làm gì có trường hợp có học sinh mà không có lớp? hoặc không học lớp nào !$@!!

.
---
Nếu bạn làm trong ngành giáo dục thì nên tham khảo code này (rất hữu ích, code rất tốt) và bạn yên tâm tôi cũng dốt :-=

.

ndu96081631 · 16/11/09

tam8678 đã viết:
---
Code tốt lắm rồi, chú có thể thêm trong trường hợp này được không?, xóa sạch dữ liệu tất cả các sheet (đương nhiên không xóa sheet Data) trước khi chạy code nhằm tránh trường hợp...theo ví dụ trên là nhập lớp: nhập lớp 2A3 vào lớp 2A1 => lớp 2A1: đúng (vì có code trên), lớp 2A3: dữ liệu vẫn còn (rỗng mới đúng, nếu phức tạp thì không cần xóa sheet 2A3). Không biết chú có đồng ý không?

Cái này cũng hợp lý ---> Thêm tí code nữa là xong! Nguyên tắc: Đầu tiên trước khi chạy code là xóa tất tần tần hết các sheet!
Vậy thì code sẽ thế này:

PHP:

Sub Loc()
  Dim Sh As Worksheet, DelSh As Worksheet, Item
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error Resume Next
  Set Sh = Sheets("DS toan truong")
  For Each DelSh In ThisWorkbook.Worksheets
    If DelSh.Name <> Sh.Name Then DelSh.Delete
  Next
  With Sh.Range(Sh.[A7], Sh.[W65536].End(xlUp))
    For Each Item In UniqueList(.Offset(1, 22).Resize(, 1))
      Sheets.Add.Name = Item
      .AutoFilter 23, Item
      .SpecialCells(12).Copy: Sheets(Item).Range("A1").PasteSpecial 3
      .AutoFilter
      With Sheets(Item)
        .Move After:=Sheets(Sheets.Count)
        .Range("1:1").Font.Bold = True
        .Range("1:1").HorizontalAlignment = xlCenter
        .Range("A:W").EntireColumn.AutoFit
        .Range("C2:C1000").NumberFormat = "dd/mm/yyyy"
        .Range(.Range("A2"), .Range("A65536").End(xlUp)).Value = Evaluate("ROW(R:R)")
      End With
    Next
    .Parent.Activate
  End With
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Đương nhiên trường hợp này ta không cần kiểm tra sự tồn tại của sheet ---> vì thật chất chẳng có sheet nào tồn tại, nó bị xóa hết còn đâu ---> Như thế thì cứ Add sheeet (mà không cần kiểm tra)
Anh xem lại code mới này thế nào nhé
--------------------------------
Nói thêm: Em còn 1 chiêu khác dùng Advanced Filter và không cần dùng đến hàm UniqueList ---> Các bạn khác cứ nghiên cứu (từ từ em sẽ đưa lên)

tam8678 · 16/11/09

ndu96081631 đã viết:
Cái này cũng hợp lý ---> Thêm tí code nữa là xong! Nguyên tắc: Đầu tiên trước khi chạy code là xóa tất tần tần hết các sheet!
Vậy thì code sẽ thế này:

PHP:

Sub Loc() Dim Sh As Worksheet, DelSh As Worksheet, Item Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Set Sh = Sheets("DS toan truong") For Each DelSh In ThisWorkbook.Worksheets If DelSh.Name <> Sh.Name Then DelSh.Delete Next With Sh.Range(Sh.[A7], Sh.[W65536].End(xlUp)) For Each Item In UniqueList(.Offset(1, 22).Resize(, 1)) Sheets.Add.Name = Item .AutoFilter 23, Item .SpecialCells(12).Copy: Sheets(Item).Range("A1").PasteSpecial 3 .AutoFilter With Sheets(Item) .Move After:=Sheets(Sheets.Count) .Range("1:1").Font.Bold = True .Range("1:1").HorizontalAlignment = xlCenter .Range("A:W").EntireColumn.AutoFit .Range("C2:C1000").NumberFormat = "dd/mm/yyyy" .Range(.Range("A2"), .Range("A65536").End(xlUp)).Value = Evaluate("ROW(R:R)") End With Next .Parent.Activate End With Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

Đương nhiên trường hợp này ta không cần kiểm tra sự tồn tại của sheet ---> vì thật chất chẳng có sheet nào tồn tại, nó bị xóa hết còn đâu ---> Như thế thì cứ Add sheeet (mà không cần kiểm tra)
Anh xem lại code mới này thế nào nhé
--------------------------------
Nói thêm: Em còn 1 chiêu khác dùng Advanced Filter và không cần dùng đến hàm UniqueList ---> Các bạn khác cứ nghiên cứu (từ từ em sẽ đưa lên)

---
Hỏi thật, chú đừng cười anh, file trong bài 17 không hiểu chú để hàm UniqueList nằm ở đâu, chỉ giúp anh nhé. Code này vận dụng tốt sẽ giải quyết được rất nhiều việc (anh yếu lắm chú ơi...!).

sealand · 16/11/09

Mình bổ xung phương pháp thêm 1 cột phụ vào sheet toàn trường (cột màu đỏ) rồi dùng công thức , thoát ly VBA. Tốc độ được cải thiện nhiều. Cần thêm lóp thì chỉ cần chép thêm 1 sheet lớp rồi gõ lại tên lớp ở ô J3 là được.

ndu96081631 · 16/11/09

tam8678 đã viết:
---
Hỏi thật, chú đừng cười anh, file trong bài 17 không hiểu chú để hàm UniqueList nằm ở đâu, chỉ giúp anh nhé. Code này vận dụng tốt sẽ giải quyết được rất nhiều việc (anh yếu lắm chú ơi...!).

Anh bấm Alt + F11 sẽ thấy ngay mà ---> Hàm ấy nằm ngay dưới code trên
Sẳn đây em xin gữi 1 "chiêu" khác: không dùng hàm UniqueList luôn, code chỉ có duy nhất thế này:

PHP:

Sub Loc()
  Dim Sh As Worksheet, FRng As Range, DelSh As Worksheet
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error Resume Next
  Set Sh = Sheets("DS toan truong")
  For Each DelSh In ThisWorkbook.Worksheets
    If DelSh.Name <> Sh.Name Then DelSh.Delete
  Next
  With Sh.Range(Sh.[A7], Sh.[W65536].End(xlUp))
    .Offset(, 22).Resize(, 1).AdvancedFilter 2, , Sh.Range("IV1"), True
    Sh.Range("IV:IV").Sort Sh.[IV1], 1, Header:=xlYes
    Set FRng = Sh.Range("IV1").CurrentRegion
    If FRng.Rows.Count > 1 Then
      Do
        Sheets.Add.Name = FRng(2).Value
        .AdvancedFilter 2, FRng.Resize(2), Sheets(FRng(2).Value).Range("A1")
        With Sheets(FRng(2).Value)
          .Move After:=Sheets(Sheets.Count)
          .Range("A:W").EntireColumn.AutoFit
          .Range(.Range("A2"), .Range("A65536").End(xlUp)).Value = Evaluate("ROW(R:R)")
        End With
        FRng(2).Delete 2
      Loop Until FRng.CurrentRegion.Rows.Count = 1
    End If
    FRng.EntireColumn.Clear
    .Parent.Activate
  End With
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Code chủ yếu dùng Advanced Filter (lọc duy nhất cột W ra cột IV) ---> Code này có gọn hơn (vì không dùng hàm hổ trợ) nhưng nhược điểm của nó là cột IV phải chưa sử dụng

Nhờ anh chị giúp em khi nhập liệu tổng hợp thì sẽ tự động chạy qua Sheet 2A1, 2A2,...

Thành viên hoạt động

File đính kèm

/(hông là gì!

Đời Xá Chi

Huyền thoại GPE

File đính kèm

Đời Xá Chi

Huyền thoại GPE

File đính kèm

Đời Xá Chi

Thành viên tiêu biểu

File đính kèm

Thành viên mới

Gội rồi mới Cạo

Đời Xá Chi

Thành viên hoạt động

Đời Xá Chi

Thành viên mới

Thành viên gạo cội

File đính kèm

Đời Xá Chi

Huyền thoại GPE

File đính kèm

Đời Xá Chi

Thành viên gạo cội

File đính kèm

Huyền thoại GPE

File đính kèm

Đếm ngược thời gian