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,... (1 người xem)

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

tam8678 · 16/11/09

ndu96081631 đã viết:
Anh bấm Alt + F11 sẽ thấy ngay mà ---> Hàm ấy nằm ngay dưới code trên

---
Nếu được, hướng dẫn giúp anh hàm UniqueList.
Cám ơn.

tamhoncuada10313 · 16/11/09

Bác ndu96081631 ơi! e muốn làm như file test của bác nhưng cột để tách ra của em không phải ở cuối cùng mà là cột thứ 4 thì e phải sửa ở đâu trong code hả bác.

ndu96081631 · 16/11/09

tam8678 đã viết:
---
Nếu được, hướng dẫn giúp anh hàm UniqueList.
Cám ơn.

Anh có thể xem em ứng dụng UniqueList trong bài này như thế nào nhé:
http://www.giaiphapexcel.com/forum/showthread.php?t=30255
------------------

tamhoncuada10313 đã viết:
Bác ndu96081631 ơi! e muốn làm như file test của bác nhưng cột để tách ra của em không phải ở cuối cùng mà là cột thứ 4 thì e phải sửa ở đâu trong code hả bác.

Để thuận tiện cho bạn tùy ý chọn vùng dử liệu và cột điều kiện trích lọc, tôi sửa lại, dùng InputBox cho bạn chọn nhé:

PHP:

Sub Loc()
  Dim Sh As Worksheet, DelSh As Worksheet, Item, SrcRng As Range, CriteriaRng As Range
  Application.DisplayAlerts = False
  On Error Resume Next
  Set SrcRng = Application.InputBox("Chon vung du lieu", Type:=8)
  If SrcRng Is Nothing Then Exit Sub
  Set CriteriaRng = Application.InputBox("Chon cot du lieu ma ban can trich", Type:=8)
  Set CriteriaRng = Intersect(CriteriaRng.EntireColumn, SrcRng, SrcRng.Offset(1))
  If CriteriaRng Is Nothing Then Exit Sub
  Application.ScreenUpdating = False
  Set Sh = Sheets("DS toan truong")
  For Each DelSh In ThisWorkbook.Worksheets
    If DelSh.Name <> Sh.Name Then DelSh.Delete
  Next
  With SrcRng
    For Each Item In UniqueList(CriteriaRng)
      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

Chú ý:
- Với InputBox chọn vùng dử liệu, bắt buộc bạn phải chọn toàn bộ, bao gồm cả tiêu đề
- Với InputBox chọn cột điều kiện lọc, bạn có thể chọn nguyên cột hoặc thậm chí 1 cell trong cột này cũng được
xem file

thuanduc08 · 16/11/09

Xin cảm ơn các bác, em đã giải quyết được vấn đề mà đã lâu em mất thời gian vì nó. Nếu bạn nào quan tâm thì nên dùng cách đầu tiên mà anh Ndu96081... đã làm vì 1 file bao giờ cũng có sheet tổng hợp, nếu dùng cách sau thì soá mất sheet đó còn gì. Nhưng để đoạn code này có tính năng cao hơn các bác có thể cho thêm phần lọc các đối tượng ví dụ: con TB, HSKK, giới tính, độ tuổi. Em chắc chắn sẽ rất nhiều người đang cần. Cảm ơn anh Ndu96081 ... nhiều.
À thêm tí nữa anh Ndu96081 .... có thể hướng dẫn thêm phần tạo nút lệnh được ko? phần này em "gà tồ" lắm.

tam8678 · 17/11/09

thuanduc08 đã viết:
...đã làm vì 1 file bao giờ cũng có sheet tổng hợp, nếu dùng cách sau thì soá mất sheet đó còn gì.

---
Tôi theo các bài của Ndu rất kỹ, các bài của Ndu càng về sau càng hoàn thiện và dễ xử dụng, bạn nói rõ xem bài nào thì xóa mất sheet tổng hợp, phân tích dữ liệu mà ảnh hưởng (chứ đừng nói đến xóa dữ liệu) thì phân tích làm gì hả bạn?
---

To: HNB, không thấy file đính kèm thì các bạn không giúp bạn được đâu. Thân chào
---
To: NDU, anh đang không hiểu cách xử dụng hàm InStr, chú giúp anh xem bài nói về hàm này ở đâu :-=

ndu96081631 · 17/11/09

tam8678 đã viết:
---
Tôi theo các bài của Ndu rất kỹ, các bài của Ndu càng về sau càng hoàn thiện và dễ xử dụng, bạn nói rõ xem bài nào thì xóa mất sheet tổng hợp, phân tích dữ liệu mà ảnh hưởng (chứ đừng nói đến xóa dữ liệu) thì phân tích làm gì hả bạn?
---

To: HNB, không thấy file đính kèm thì các bạn không giúp bạn được đâu. Thân chào

Hình như em hơi hiểu ý của tác giả:
- File sau này là em làm theo yêu cầu của anh: Khi có thay đổi tại sheet nhập liệu, nếu không tìm thấy LỚP trước đó thì xóa đi luôn
- Còn tác giả có lẽ muốn giữ lại những gì trước đó
Mổi người mổi yêu cầu khác nhau ---> Tùy thích sử dụng

HNB · 17/11/09

tam8678 đã viết:
---
Tôi theo các bài của Ndu rất kỹ, các bài của Ndu càng về sau càng hoàn thiện và dễ xử dụng, bạn nói rõ xem bài nào thì xóa mất sheet tổng hợp, phân tích dữ liệu mà ảnh hưởng (chứ đừng nói đến xóa dữ liệu) thì phân tích làm gì hả bạn?
---

To: HNB, không thấy file đính kèm thì các bạn không giúp bạn được đâu. Thân chào
---
To: NDU, anh đang không hiểu cách xử dụng hàm InStr, chú giúp anh xem bài nói về hàm này ở đâu

Dear Bac Tam8678,

Tôi có đính kèm file mà sao nó ko post được lên nhỉ.
Tôi đã vào file đính kèm / upload file from your computer, chọn file và nhấn nút Thêm file.
Còn cách nào không bác.

Cám ơn bác tam8678 nhiều nhiều nhé.

Rgds,
HNB

tam8678 · 17/11/09

HNB đã viết:
Dear Bac Tam8678,

Tôi có đính kèm file mà sao nó ko post được lên nhỉ.
Tôi đã vào file đính kèm / upload file from your computer, chọn file và nhấn nút Thêm file.
Còn cách nào không bác.

Cám ơn bác tam8678 nhiều nhiều nhé.

Rgds,
HNB

---
Đọc kỹ phần Hướng Dẫn Sử Dụng Diển Đàn, có thể do dữ liệu nhiều ( bạn trích ít thôi hoặc nén file lại), tôi tin bạn làm được :-=

. Thân chào

tam8678 · 29/12/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é

---
Anh vận dụng code bài này để tách Sổ Chi Tiết Tài Khoản, nhưng làm không nổi, mong chú xem giúp. Sheet"CTGS" giống Sheet"DSToanTruong", Sheets"111" (làm mẫu) giống như ta phân lớp nhưng theo 2 cột (Trích theo cột D trước, cột E tìm theo cột D nếu có tài khoản trùng thì ghi vào, nếu không có thì tạo sheets mới. Nếu không rõ xin vui lòng thông báo.
Cám ơn

ndu96081631 · 30/12/09

tam8678 đã viết:
---
Anh vận dụng code bài này để tách Sổ Chi Tiết Tài Khoản, nhưng làm không nổi, mong chú xem giúp. Sheet"CTGS" giống Sheet"DSToanTruong", Sheets"111" (làm mẫu) giống như ta phân lớp nhưng theo 2 cột (Trích theo cột D trước, cột E tìm theo cột D nếu có tài khoản trùng thì ghi vào, nếu không có thì tạo sheets mới. Nếu không rõ xin vui lòng thông báo.
Cám ơn

Đúng là em không rành kế toán nên nhìn vào thấy lơ mơ quá
Anh cho hỏi: Với file của anh như vậy thì sao khi trích rút xong sẽ cho kết quả là bao nhiêu sheet? Tên sheet là gì?
Nếu có thể được, anh trích bằng tay luôn (ra kết quả toàn bộ), hy vọng em có thể hình dung được

tam8678 · 30/12/09

ndu96081631 đã viết:
Đúng là em không rành kế toán nên nhìn vào thấy lơ mơ quá
Anh cho hỏi: Với file của anh như vậy thì sao khi trích rút xong sẽ cho kết quả là bao nhiêu sheet? Tên sheet là gì?
Nếu có thể được, anh trích bằng tay luôn (ra kết quả toàn bộ), hy vọng em có thể hình dung được

---

sẽ cho kết quả là bao nhiêu sheet?

Giống như bài trên đó chú: có bao nhiêu lớp thì ra bao nhiêu sheet, có bao nhiêu tài khỏan thì ra bao nhiêu sheets ( theo cột D: 111, 131...)

Tên sheet là gì?

Tên sheets là tên lớp: 2A1 => sheets "2A1", tài khoản 111 => sheets"111"...

Nếu có thể được, anh trích bằng tay luôn (ra kết quả toàn bộ), hy vọng em có thể hình dung được

Theo bài trên thì chỉ có 1 sheets "DS Toan Truong", sau khi chạy code thì mới phân ra hàng loạt tên lớp. Ở đây cũng thế, chỉ có 1 sheets"CTGS", sau khi chạy code (theo cột D) thì mới phân ra hàng loạt theo tên tài khoản. Anh làm ví dụ cho chú hình dung rồi: sheets"111", ...
Nhưng có 1 cái khó ở đây là sau khi chạy cột D thì phải làm tiếp cột E => cái này anh thua +-+-+-+

Nếu chú chưa rõ thì thông báo nhé ( chỉ viết khi thật rõ yêu cầu chú nhé :-=

, chỉnh sữa mệt lắm)

huuthang_bd · 30/12/09

tam8678 đã viết:
---
Anh vận dụng code bài này để tách Sổ Chi Tiết Tài Khoản, nhưng làm không nổi, mong chú xem giúp. Sheet"CTGS" giống Sheet"DSToanTruong", Sheets"111" (làm mẫu) giống như ta phân lớp nhưng theo 2 cột (Trích theo cột D trước, cột E tìm theo cột D nếu có tài khoản trùng thì ghi vào, nếu không có thì tạo sheets mới. Nếu không rõ xin vui lòng thông báo.
Cám ơn

Anh thử code này xem sao. Em sửa lại mẫu sổ chi tiết một chút, gộp 2 cột thu chi lại làm cột chứng từ. Vì không phải nghiệp vụ nào cũng phát sinh thu chi.

PHP:

Sub Sochitiet()
On Error Resume Next
Dim cll As Range, Data As Range
Dim TK As String
Dim DataRows As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Sheets("CTGS").AutoFilterMode = False
Set Data = Range(Sheets("CTGS").[A5], Sheets("CTGS").[F65536].End(xlUp))
DataRows = Data.Rows.Count - 1
For Each cll In Range(Sheets("CTGS").[D6], Sheets("CTGS").[D65536].End(xlUp))
If InStr(TK, cll.Value) = 0 Then
    TK = TK & "," & cll.Value
    Sheets("Mau").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = cll.Value
    [A2].Value = cll.Value
    Data.AutoFilter 4, cll.Value
    Data.Offset(1).Resize(DataRows, 3).SpecialCells(12).Copy [A6]
    Data.Offset(1, 4).Resize(DataRows, 2).SpecialCells(12).Copy [D6]
    Data.AutoFilter 4
    Data.AutoFilter 5, cll.Value
    Data.Offset(1, 5).Resize(DataRows, 1).SpecialCells(12).Copy [D65536].End(xlUp).Offset(1 - ([D6].Value = ""), 2)
    Data.Offset(1).Resize(DataRows, 4).SpecialCells(12).Copy [D65536].End(xlUp).Offset(1 - ([D6].Value = ""), -3)
    Data.AutoFilter 5
End If

If InStr(TK, cll.Offset(, 1).Value) = 0 Then
    TK = TK & "," & cll.Offset(, 1).Value
    Sheets("Mau").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = cll.Offset(, 1).Value
    [A2].Value = cll.Offset(, 1).Value
    Data.AutoFilter 4, cll.Offset(, 1).Value
    Data.Offset(1).Resize(DataRows, 3).SpecialCells(12).Copy [A6]
    Data.Offset(1, 4).Resize(DataRows, 2).SpecialCells(12).Copy [D6]
    Data.AutoFilter 4
    Data.AutoFilter 5, cll.Offset(, 1).Value
    Data.Offset(1, 5).Resize(DataRows, 1).SpecialCells(12).Copy [D65536].End(xlUp).Offset(1 - ([D6].Value = ""), 2)
    Data.Offset(1).Resize(DataRows, 4).SpecialCells(12).Copy [D65536].End(xlUp).Offset(1 - ([D6].Value = ""), -3)
    Data.AutoFilter 5
End If

Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

tam8678 · 30/12/09

huuthang_bd đã viết:
Anh thử code này xem sao. Em sửa lại mẫu sổ chi tiết một chút, gộp 2 cột thu chi lại làm cột chứng từ. Vì không phải nghiệp vụ nào cũng phát sinh thu chi.

---
Rất cám ơn sự góp ý của Thắng, có thêm 1 sheets "Mau" nhìn thông thoáng hơn :-=

Anh thử code này xem sao

Thắng thử Run code 2 lần liên tục sẽ thấy ngay vấn đề hoặc Run code lần 1 xong, ghi thêm 1 phát sinh vào Sheets"CTGS", tiếp tục Run code => **~**

.
Mến.

huuthang_bd · 30/12/09

tam8678 đã viết:
---

Thắng thử Run code 2 lần liên tục sẽ thấy ngay vấn đề hoặc Run code lần 1 xong, ghi thêm 1 phát sinh vào Sheets"CTGS", tiếp tục Run code => .
Mến.

Em biết điều này chứ. Trước khi tạo sổ anh phải xoá hết tất cả các sổ chi tiết. Nếu không muốn xoá bằng tay thì viết code tự xoá luôn. Thêm đoạn này vào:

PHP:

For Each sh In Sheets
If sh.Name <> "Mau" And sh.Name <> "CTGS" Then sh.Delete
Next

Đây là code sau khi đã sửa lại:

PHP:

Sub Sochitiet()
On Error Resume Next
Dim cll As Range, Data As Range
Dim TK As String
Dim DataRows As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Name <> "Mau" And sh.Name <> "CTGS" Then sh.Delete
Next
Sheets("CTGS").AutoFilterMode = False
Set Data = Range(Sheets("CTGS").[A5], Sheets("CTGS").[F65536].End(xlUp))
DataRows = Data.Rows.Count - 1
For Each cll In Range(Sheets("CTGS").[D6], Sheets("CTGS").[D65536].End(xlUp))
If InStr(TK, cll.Value) = 0 Then
    TK = TK & "," & cll.Value
    Sheets("Mau").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = cll.Value
    [A2].Value = cll.Value
    Data.AutoFilter 4, cll.Value
    Data.Offset(1).Resize(DataRows, 3).SpecialCells(12).Copy [A6]
    Data.Offset(1, 4).Resize(DataRows, 2).SpecialCells(12).Copy [D6]
    Data.AutoFilter 4
    Data.AutoFilter 5, cll.Value
    Data.Offset(1, 5).Resize(DataRows, 1).SpecialCells(12).Copy [D65536].End(xlUp).Offset(1 - ([D6].Value = ""), 2)
    Data.Offset(1).Resize(DataRows, 4).SpecialCells(12).Copy [D65536].End(xlUp).Offset(1 - ([D6].Value = ""), -3)
    Data.AutoFilter 5
End If
If InStr(TK, cll.Offset(, 1).Value) = 0 Then
    TK = TK & "," & cll.Offset(, 1).Value
    Sheets("Mau").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = cll.Offset(, 1).Value
    [A2].Value = cll.Offset(, 1).Value
    Data.AutoFilter 4, cll.Offset(, 1).Value
    Data.Offset(1).Resize(DataRows, 3).SpecialCells(12).Copy [A6]
    Data.Offset(1, 4).Resize(DataRows, 2).SpecialCells(12).Copy [D6]
    Data.AutoFilter 4
    Data.AutoFilter 5, cll.Offset(, 1).Value
    Data.Offset(1, 5).Resize(DataRows, 1).SpecialCells(12).Copy [D65536].End(xlUp).Offset(1 - ([D6].Value = ""), 2)
    Data.Offset(1).Resize(DataRows, 4).SpecialCells(12).Copy [D65536].End(xlUp).Offset(1 - ([D6].Value = ""), -3)
    Data.AutoFilter 5
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

Và đây là file

Phanhanhdai · 27/3/11

tam8678 đã viết:
---
Tôi theo các bài của Ndu rất kỹ, các bài của Ndu càng về sau càng hoàn thiện và dễ xử dụng, bạn nói rõ xem bài nào thì xóa mất sheet tổng hợp, phân tích dữ liệu mà ảnh hưởng (chứ đừng nói đến xóa dữ liệu) thì phân tích làm gì hả bạn?
---

To: HNB, không thấy file đính kèm thì các bạn không giúp bạn được đâu. Thân chào
---
To: NDU, anh đang không hiểu cách xử dụng hàm InStr, chú giúp anh xem bài nói về hàm này ở đâu

Em theo dõi nhiều bài của thày ndu trên diễn đàn, từ khi thày dùng nick anhtuan1066 gì đó, các bài của thày đều rất độc đáo, trước kia em được Sếp giao làm dự toán dự thầu nếu gói thầu cỡ 50 hạng mục thì em phải mất gần 1 tháng mới làm ra, nay nhờ có thày và mọi người trên GPE, những bài như thế em chỉ làm rút gọn khoảng 5 ngày kể cả nhập dữ liệu, hoàn chỉnh chỉ để in thôi. Riêng chú VBA của các thày giá như em được học trực tiếp thì tốt quá, trước thày Tuân có dạy ở Hà nội nhưng em làm thường đến 6h tối mới hết việc, đi xe buýt ra HN mất gần 3 tiếng nên đành chịu. Các thày có thể nghĩ ra hình thức đào tạo trực tuyến hay hình thức khác để bọn em ở các tỉnh lẻ như Hải Dương, Hưng Yên, Thái Bình...có thể học được không ah. Chứ các lớp các thày mở chỉ mỗi các thành phố lớn học được, bọn em không có cách gì để bố trí thời gian theo được. Rất mong các thày quan tâm.

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,... (1 người xem)

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

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

Đời Xá Chi

Thành viên thường trực

Huyền thoại GPE

File đính kèm

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

Đời Xá Chi

Huyền thoại GPE

Thành viên mới

Đời Xá Chi

Đời Xá Chi

File đính kèm

Huyền thoại GPE

Đời Xá Chi

Chuyên gia GPE

File đính kèm

Đời Xá Chi

Chuyên gia GPE

File đính kèm

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

Thời gian đếm ngược.