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,...

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,...

tam8678

Đời Xá Chi

tamhoncuada10313

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

ndu96081631

Huyền thoại GPE

File đính kèm

thuanduc08

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

tam8678

Đời Xá Chi

ndu96081631

Huyền thoại GPE

HNB

Thành viên mới

tam8678

Đời Xá Chi

tam8678

Đời Xá Chi

File đính kèm

ndu96081631

Huyền thoại GPE

tam8678

Đời Xá Chi

huuthang_bd

Chuyên gia GPE

File đính kèm

tam8678

Đời Xá Chi

huuthang_bd

Chuyên gia GPE

File đính kèm

Phanhanhdai

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

Bài viết mới nhất

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