Lọc Mã duy I theo từng tháng, rồi sắp xếp các Mã giống như bảng mẫu chuẩn có sẵn.

Liên hệ QC
Hong.Van

Hong.Van

Busy
Tham gia
7/5/12
Bài viết
2,330
Được thích
1,763
Thầy cô & anh chị vui lòng giúp em viết code như sau:
Em xin lấy tháng 02 làm ví dụ

1/ Giả sử tại Sheet "ChiTiet", cell D5 là ngày 01/02/2013 (đang lấy tháng 02). Ta sang Sheet "TH" lấy các ngày tương ứng tháng 2 là khối cell AI251:AJ270.

2/ Khối cell AI251:AJ270 ta chỉ lấy mã DUY NHẤT, rồi sắp xếp các Mã này theo thứ tự từ trên xuống dưới giống như khối cell BA10:BA102 của Sheet "Ma" (dĩ nhiên Mã nào có thì mới xếp thứ tự, không có thì thôi)

3/ Sau khi sắp xếp thì code cho kết qủa tại cell J12 của sheet "ChiTiết"
-----------
P/s: Em đã làm kết qủa bằng tay của khối cell J12:J31 (Sheet "ChiTiet")
Mục đích của em là tạo List Validation
Em cảm ơn!
 

File đính kèm

  • LocMa.rar
    21.2 KB · Đọc: 31
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn tham khảo Code sau (chú ý tôi chưa bắt lỗi đối với việc sheet Th có filter hay không, nếu filter sẽ lỗi - cái này chắc bạn xử lý được)
Mã: 
Sub LocTaiKhoan()
    Dim Arr, sArr
    Dim Dic As Object
    Dim i As Long, k As Long, j As Long
    Dim ClsDate As Date
    Dim Tmp As Double

    Set Dic = CreateObject("Scripting.Dictionary")
    ClsDate = Sheets("chitiet").[d5]
    Arr = Sheets("Th").Range("AB9:AJ" & Sheets("TH").Range("AJ65536").End(3).Row)
    ReDim sArr(1 To UBound(Arr, 1), 1 To 1)
    'Unique list...............
    With Dic
        For i = 1 To UBound(Arr, 1)
            If Arr(i, 1) = ClsDate Then
                If Not .Exists(Arr(i, 8)) Then
                    k = k + 1
                    .Add Arr(i, 8), k
                    sArr(k, 1) = Arr(i, 8)
                End If
                If Not .Exists(Arr(i, 9)) Then
                    k = k + 1
                    .Add Arr(i, 9), k
                    sArr(k, 1) = Arr(i, 9)
                End If
            End If
        Next
    End With
    'Sort......................
    For i = 1 To k - 1
        For j = i + 1 To k
            If sArr(i, 1) * 10 ^ (10 - Len(sArr(i, 1))) _
               > sArr(j, 1) * 10 ^ (10 - Len(sArr(j, 1))) Then
                Tmp = sArr(i, 1)
                sArr(i, 1) = sArr(j, 1)
                sArr(j, 1) = Tmp
            End If
        Next
    Next
    Sheets("chitiet").[J12].Resize(k, 1) = sArr
End Sub
 
Upvote 0
Hi, anh hiểu nhầm ý em rồi,
Ý em là, nếu cell D5 của sheet "Chi tiết" là ngày 01/02/2013 hoặc 28/02/2013 thì lọc TẤT CẢ các ngày của tháng 02 chứ không phải lọc riêng ngày 01/02/2013 hoặc 28/02/2013
Mặt khác, nếu chưa có phát sinh tháng 04 bên sheet TH, mà cell D5 của sheet "Chi tiết" nhập các ngày của tháng 04 thì code báo lỗi
Anh sửa code và bẫy lỗi giúp em, em cảm ơn!
 
Upvote 0
Bạn xem đúng ý chưa nhé
Mã: 
Sub LocTaiKhoan()
    Dim Arr, sArr
    Dim Dic As Object
    Dim i As Long, k As Long, j As Long
    Dim ClsDate As Long
    Dim Tmp As Double
    Sheets("chitiet").AutoFilterMode = False
    Set Dic = CreateObject("Scripting.Dictionary")
    ClsDate = Month(Sheets("chitiet").[d5])
    Arr = Sheets("Th").Range("AB9:AJ" & Sheets("TH").Range("AJ65536").End(3).Row)
    ReDim sArr(1 To UBound(Arr, 1), 1 To 1)
    'Unique list...............
    With Dic
        For i = 1 To UBound(Arr, 1)
            If Month(Arr(i, 1)) = ClsDate And Arr(i, 1) <> "" Then
                For j = 8 To 9
                    If Not .Exists(Arr(i, j)) Then
                        k = k + 1
                        .Add Arr(i, j), k
                        sArr(k, 1) = Arr(i, j)
                    End If
                Next
            End If
        Next
    End With
    If k = 0 Then
        MsgBox "Khong co thang " & ClsDate & " trong Sheet TH"
        Sheets("chitiet").Range(Sheets("chitiet").[J12], Sheets("chitiet").[J65536].End(3)).ClearContents
        Exit Sub
    End If
    'Sort......................
    For i = 1 To k - 1
        For j = i + 1 To k
            If sArr(i, 1) * 10 ^ (10 - Len(sArr(i, 1))) _
               > sArr(j, 1) * 10 ^ (10 - Len(sArr(j, 1))) Then
                Tmp = sArr(i, 1)
                sArr(i, 1) = sArr(j, 1)
                sArr(j, 1) = Tmp
            End If
        Next
    Next
    Sheets("chitiet").Range(Sheets("chitiet").[J12], Sheets("chitiet").[J65536].End(3)).ClearContents
    Sheets("chitiet").[J12].Resize(k, 1) = sArr
End Sub
 
Upvote 0
Hong.Van đã viết:
Thầy cô & anh chị vui lòng giúp em viết code như sau:
Em xin lấy tháng 02 làm ví dụ

1/ Giả sử tại Sheet "ChiTiet", cell D5 là ngày 01/02/2013 (đang lấy tháng 02). Ta sang Sheet "TH" lấy các ngày tương ứng tháng 2 là khối cell AI251:AJ270.

2/ Khối cell AI251:AJ270 ta chỉ lấy mã DUY NHẤT, rồi sắp xếp các Mã này theo thứ tự từ trên xuống dưới giống như khối cell BA10:BA102 của Sheet "Ma" (dĩ nhiên Mã nào có thì mới xếp thứ tự, không có thì thôi)

3/ Sau khi sắp xếp thì code cho kết qủa tại cell J12 của sheet "ChiTiết"
-----------
P/s: Em đã làm kết qủa bằng tay của khối cell J12:J31 (Sheet "ChiTiet")
Mục đích của em là tạo List Validation
Em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Theo như kết quả bạn đưa ra thì có những số 1331,1561,242,331,4212,62741 bạn lấy từ đâu? vì mình không thấy trong tháng 2 có những TK này.
 
Upvote 0
Hong.Van đã viết:
đúng rồi anh ơi!!!!!!!!!!!!!!
Nhấp chuột vào đây để mở rộng...
Vậy bạn dùng ado như sau nhé.

[GPECODE=sql]Sub Loc_HLMT()
Dim adoConn As Object, adoRS As Object
Set adoConn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("ADODB.Recordset")
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
.Open
End With
With adoRS
.ActiveConnection = adoConn
.Open "select distinct F8 from " _
& "(select f1, F8 from [TH$AB9:AJ1000] " _
& "union all " _
& "select f1, F9 from [TH$AB9:AJ1000]) " _
& "where month(f1)=" & Month(Sheet3.Range("D5"))
End With
With Sheet3
.[J12:J65000].ClearContents
.[J12].CopyFromRecordset adoRS
End With
adoRS.Close: Set adoRS = Nothing
adoConn.Close: Set adoConn = Nothing

End Sub
[/GPECODE]
 
Upvote 0
Hai Lúa Miền Tây đã viết:
Vậy bạn dùng ado như sau nhé.

[GPECODE=sql]Sub Loc_HLMT()
Dim adoConn As Object, adoRS As Object
Set adoConn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("ADODB.Recordset")
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
.Open
End With
With adoRS
.ActiveConnection = adoConn
.Open "select distinct F8 from " _
& "(select f1, F8 from [TH$AB9:AJ1000] " _
& "union all " _
& "select f1, F9 from [TH$AB9:AJ1000]) " _
& "where month(f1)=" & Month(Sheet3.Range("D5"))
End With
With Sheet3
.[J12:J65000].ClearContents
.[J12].CopyFromRecordset adoRS
End With
adoRS.Close: Set adoRS = Nothing
adoConn.Close: Set adoConn = Nothing

End Sub
[/GPECODE]
Nhấp chuột vào đây để mở rộng...
Code của anh mới lọc duy nhất & nó sắp xếp theo thứ tự từ nhỏ đến lớn
Yêu cầu của em là sắp xếp các Mã này theo thứ tự từ trên xuống dưới giống như khối cell BA10:BA102 của Sheet "Ma" (dĩ nhiên Mã nào có thì mới xếp thứ tự, không có thì thôi)
Ví dụ : Tháng 02
Code của anh nó sắp xếp như sau: 131, 242, 331, 911, 1111, 1121, 1331, 1411, 1561, 2141, 4212, 6322, 6323, 6411, 6421, 6422, 6423, 6424, 6427, 62741
Yêu cầu của em nó sắp xếp là: 1111, 1121, 131, 1331, 1411, 1561, 2141, 242, 331, 4212, 62741, 6322, 6323, 6411, 6421, 6422, 6423, 6424, 6427, 911
Em cảm ơn!
--------------
P/s: Mục đích của em là tạo List Validation, để in sổ sách theo Mã tài khoản đó!
 
Upvote 0
Hong.Van đã viết:
Code của anh mới lọc duy nhất & nó sắp xếp theo thứ tự từ nhỏ đến lớn
Yêu cầu của em là sắp xếp các Mã này theo thứ tự từ trên xuống dưới giống như khối cell BA10:BA102 của Sheet "Ma" (dĩ nhiên Mã nào có thì mới xếp thứ tự, không có thì thôi)
Ví dụ : Tháng 02
Code của anh nó sắp xếp như sau: 131, 242, 331, 911, 1111, 1121, 1331, 1411, 1561, 2141, 4212, 6322, 6323, 6411, 6421, 6422, 6423, 6424, 6427, 62741
Yêu cầu của em nó sắp xếp là: 1111, 1121, 131, 1331, 1411, 1561, 2141, 242, 331, 4212, 62741, 6322, 6323, 6411, 6421, 6422, 6423, 6424, 6427, 911
Em cảm ơn!
--------------
P/s: Mục đích của em là tạo List Validation, để in sổ sách theo Mã tài khoản đó!
Nhấp chuột vào đây để mở rộng...

ADO sẽ không sort theo ý bạn được, xin lỗi nhé.
 
Upvote 0
Không biết bài #4 có đáp ứng được nhu cầu của bạn không?
@Anh HLMT: Ado có thể tạo thêm 1 trường nữa lấy kết quả theo thuật toán bài #4, rồi sắp xếp dữ liệu gồm trường đã trích lọc và trường thêm vào theo độ lớn trường vừa thêm không an h. ( ADO hay quá anh ah.)
 
Upvote 0
Hai Lúa Miền Tây đã viết:
ADO sẽ không sort theo ý bạn được, xin lỗi nhé.
Nhấp chuột vào đây để mở rộng...
Thực tế Khối cell BA10:BA102 của sheet Mã là sắp xếp có thứ tự:
Trong kế toán có các cấp tài khoản như sau:
Tài khoản cấp I có 3 ký tự, Tài khoản cấp II có 4 ký tự (Cấp tài khoản con), Tài khoản cấp III có 5 ký tự (Cấp tài khoản cháu)...
Ví dụ:
Tài khỏan 111 có các tài khoản con là 1111, 1112
Tương tự Tài khỏan 112 có các tài khoản con là 1121, 1122
Tương tự Tài khỏan 511 có các tài khoản con là 5111, 5112, 5113
Tài khoản 911
...
Thông thường nếu sắp xếp theo tài khỏan cấp I, thì sẽ theo thứ tự từ nhỏ đến lớn. Ví dụ: 111,112,...,511,...,911
Nếu tài khỏan nào có tài khoản con hay cháu thì yêu cầu sắp xếp các tài khoản này liền kề với nó:
Ví dụ: 111, 1111, 1112, 112, 1121, 1122, ....,511, 5111, 5112, 5113, ..., 911
Nhưng thực tế em chỉ cần 1 số tài khỏan nên bỏ bớt như sau (bỏ bớt những mã có chữ màu đỏ)
1111, 1121, ...., 5111, 5112, 5113, ..., 911
---------
Hi, giải thích kiểu này mong anh hiểu!
 
Upvote 0
Hong.Van đã viết:
Thực tế Khối cell BA10:BA102 của sheet Mã là sắp xếp có thứ tự:
Trong kế toán có các cấp tài khoản như sau:
Tài khoản cấp I có 3 ký tự, Tài khoản cấp II có 4 ký tự (Cấp tài khoản con), Tài khoản cấp III có 5 ký tự (Cấp tài khoản cháu)...
Ví dụ:
Tài khỏan 111 có các tài khoản con là 1111, 1112
Tương tự Tài khỏan 112 có các tài khoản con là 1121, 1122
Tương tự Tài khỏan 511 có các tài khoản con là 5111, 5112, 5113
Tài khoản 911
...
Thông thường nếu sắp xếp theo tài khỏan cấp I, thì sẽ theo thứ tự từ nhỏ đến lớn. Ví dụ: 111,112,...,511,...,911
Nếu tài khỏan nào có tài khoản con hay cháu thì yêu cầu sắp xếp các tài khoản này liền kề với nó:
Ví dụ: 111, 1111, 1112, 112, 1121, 1122, ....,511, 5111, 5112, 5113, ..., 911
Nhưng thực tế em chỉ cần 1 số tài khỏan nên bỏ bớt như sau (bỏ bớt những mã có chữ màu đỏ)
1111, 1121, ...., 5111, 5112, 5113, ..., 911
---------
Hi, giải thích kiểu này mong anh hiểu!
Nhấp chuột vào đây để mở rộng...

Chuyển mã TK thành text rồi sort, muốn chuyển lại thành number thì chuyển, bằng không thì thôi.
Như vậy được không?
 

File đính kèm

  • LocMa.rar
    29.8 KB · Đọc: 8
Upvote 0
Hong.Van đã viết:
Thực tế Khối cell BA10:BA102 của sheet Mã là sắp xếp có thứ tự:
Trong kế toán có các cấp tài khoản như sau:
Tài khoản cấp I có 3 ký tự, Tài khoản cấp II có 4 ký tự (Cấp tài khoản con), Tài khoản cấp III có 5 ký tự (Cấp tài khoản cháu)...
Ví dụ:
Tài khỏan 111 có các tài khoản con là 1111, 1112
Tương tự Tài khỏan 112 có các tài khoản con là 1121, 1122
Tương tự Tài khỏan 511 có các tài khoản con là 5111, 5112, 5113
Tài khoản 911
...
Thông thường nếu sắp xếp theo tài khỏan cấp I, thì sẽ theo thứ tự từ nhỏ đến lớn. Ví dụ: 111,112,...,511,...,911
Nếu tài khỏan nào có tài khoản con hay cháu thì yêu cầu sắp xếp các tài khoản này liền kề với nó:
Ví dụ: 111, 1111, 1112, 112, 1121, 1122, ....,511, 5111, 5112, 5113, ..., 911
Nhưng thực tế em chỉ cần 1 số tài khỏan nên bỏ bớt như sau (bỏ bớt những mã có chữ màu đỏ)
1111, 1121, ...., 5111, 5112, 5113, ..., 911
---------
Hi, giải thích kiểu này mong anh hiểu!
Nhấp chuột vào đây để mở rộng...

Vậy thì dùng code sau thử nhé:

[GPECODE=sql]Sub Loc_HLMT()
Dim adoConn As Object, adoRS As Object
Set adoConn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("ADODB.Recordset")
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
.Open
End With
With adoRS
.ActiveConnection = adoConn
.Open "select f8 from (select distinct F8 from " _
& "(select f1, F8 from [TH$AB9:AJ1000] " _
& "union all " _
& "select f1, F9 from [TH$AB9:AJ1000]) " _
& "where month(f1)=" & Month(Sheet3.Range("D5")) _
& ") order by left(F8,3)"
End With
With Sheet3
.[J12:J65000].ClearContents
.[J12].CopyFromRecordset adoRS
End With
adoRS.Close: Set adoRS = Nothing
adoConn.Close: Set adoConn = Nothing
End Sub[/GPECODE]

dhn46 đã viết:
Không biết bài #4 có đáp ứng được nhu cầu của bạn không?
@Anh HLMT: Ado có thể tạo thêm 1 trường nữa lấy kết quả theo thuật toán bài #4, rồi sắp xếp dữ liệu gồm trường đã trích lọc và trường thêm vào theo độ lớn trường vừa thêm không an h. ( ADO hay quá anh ah.)
Nhấp chuột vào đây để mở rộng...

Có thể mở rộng ra được đó bạn, vậy bạn cho bài tập mẫu thử nhé.
 
Lần chỉnh sửa cuối:
Upvote 0
1/ Bài #15 của thầy Ba Tê, chỉ còn thiếu bẫy lỗi thôi ạ, Ví dụ Sheet TH chưa có tháng 4, mà chạy code cho Tháng 4 thì báo lỗi
----------------------
2/ Bài #16 của anh Hai Lúa Miền Tây thì khi sắp xếp chưa thỏa
Em ví dụ: Tài Khoản 627 có hai tài khoản con 6274, 6277
Tài khoản 6274 có hai tài khoản con là 62741 và 62743
Như vậy nó phải xếp là 62741, 62743, 6277
Còn kết qủa chạy code của anh thì nó như sau: 6277, 62743, 62741
 
Upvote 0
Hong.Van đã viết:
1/ Bài #15 của thầy Ba Tê, chỉ còn thiếu bẫy lỗi thôi ạ, Ví dụ Sheet TH chưa có tháng 4, mà chạy code cho Tháng 4 thì báo lỗi
----------------------
2/ Bài #16 của anh Hai Lúa Miền Tây thì khi sắp xếp chưa thỏa
Em ví dụ: Tài Khoản 627 có hai tài khoản con 6274, 6277
Tài khoản 6274 có hai tài khoản con là 62741 và 62743
Như vậy nó phải xếp là 62741, 62743, 6277
Còn kết qủa chạy code của anh thì nó như sau: 6277, 62743, 62741
Nhấp chuột vào đây để mở rộng...
Chỉnh lại chút xíu là được. Bạn test thử nhé.

[GPECODE=sql]Sub Loc_HLMT()
Dim adoConn As Object, adoRS As Object
Set adoConn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("ADODB.Recordset")
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
.Open
End With
With adoRS
.ActiveConnection = adoConn
.Open "select f8 from (select distinct F8 from " _
& "(select f1, F8 from [TH$AB9:AJ1000] " _
& "union all " _
& "select f1, F9 from [TH$AB9:AJ1000]) " _
& "where month(f1)=" & Month(Sheet3.Range("D5")) _
& ") order by left(F8,3),F8"
End With
With Sheet3
.[J12:J65000].ClearContents
.[J12].CopyFromRecordset adoRS
End With
adoRS.Close: Set adoRS = Nothing
adoConn.Close: Set adoConn = Nothing
End Sub

[/GPECODE]
 
Upvote 0
Hai Lúa Miền Tây đã viết:
Chỉnh lại chút xíu là được. Bạn test thử nhé.

[GPECODE=sql]Sub Loc_HLMT()
Dim adoConn As Object, adoRS As Object
Set adoConn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("ADODB.Recordset")
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
.Open
End With
With adoRS
.ActiveConnection = adoConn
.Open "select f8 from (select distinct F8 from " _
& "(select f1, F8 from [TH$AB9:AJ1000] " _
& "union all " _
& "select f1, F9 from [TH$AB9:AJ1000]) " _
& "where month(f1)=" & Month(Sheet3.Range("D5")) _
& ") order by left(F8,3),F8"
End With
With Sheet3
.[J12:J65000].ClearContents
.[J12].CopyFromRecordset adoRS
End With
adoRS.Close: Set adoRS = Nothing
adoConn.Close: Set adoConn = Nothing
End Sub

[/GPECODE]
Nhấp chuột vào đây để mở rộng...
Mã 6277 vẫn đứng trước 62741, 62743, đúng ra thì nó đứng sau 2 em này!
Em cảm ơn
 
Upvote 0
Hong.Van đã viết:
Mã 6277 vẫn đứng trước 62741, 62743, đúng ra thì nó đứng sau 2 em này!
Em cảm ơn
Nhấp chuột vào đây để mở rộng...

Hihi, thêm tiếp điều kiện vào:

[GPECODE=sql]Sub Loc_HLMT()
Dim adoConn As Object, adoRS As Object
Set adoConn = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("ADODB.Recordset")
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
.Open
End With
With adoRS
.ActiveConnection = adoConn
.Open "select f8 from (select distinct F8 from " _
& "(select f1, F8 from [TH$AB9:AJ1000] " _
& "union all " _
& "select f1, F9 from [TH$AB9:AJ1000]) " _
& "where month(f1)=" & Month(Sheet3.Range("D5")) _
& ") order by left(F8,3),left(F8,4),left(F8,5)"
End With
With Sheet3
.[J12:J65000].ClearContents
.[J12].CopyFromRecordset adoRS
End With
adoRS.Close: Set adoRS = Nothing
adoConn.Close: Set adoConn = Nothing
End Sub

[/GPECODE]
 
Upvote 0
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

emlat3
Đặt màu xen kẽ các dòng theo ký tự
Trả lời
9
Đọc
165
ptm0412
ptm0412
A
Tính tổng dữ liệu băng dictionary
Trả lời
6
Đọc
76
DeTong
D
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
65
Đọc
977
HUONGHCKT
H
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
2
Trả lời
34
Đọc
560
Quang_Hải
Quang_Hải
B
  • Question
Chuyển đổi dữ liệu sạng dạng mảng
Trả lời
7
Đọc
154
Bích Tỷ
B
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom