Chuyên đề Bài tập VBA (1 người xem)

SA_DQ · 19/1/12

Bài I: Chuyển dữ liệu từ 1 bảng tổng hợp

Số liệu ban đầu như sau:

(Bảng 1)

Giờ muốn có 1 macro để chuyển bảng dữ liệu này thành bảng sau:

(Bảng 2)

Bài II: Hãy giúp tôi chuyển dữ liệu từ bảng 2 thành bảng 1

(húc Mừng Xuân Mới!

kyo · 19/1/12

kyo làm còn sơ sài, rất mong được mọi người góp ý
Đây là bài 1

PHP:

Sub bt1()
Dim arr
Dim i As Integer, j As Integer, k As Integer
i = 1
k = 1
Do Until Sheet1.Range("B" & i).Value = ""
    arr = Split(Sheet1.Range("B" & i).Value, ", ")
    For j = LBound(arr) To UBound(arr)
        Sheet1.Range("D" & k).Value = Sheet1.Range("A" & i).Value
        Sheet1.Range("E" & k).Value = arr(j)
        k = k + 1
    Next j
    i = i + 1
Loop
End Sub

Đây là bài 2

PHP:

Sub bt2()
Dim i As Integer, j As Integer
i = 2
j = 1
Sheet1.Range("A" & j).Value = Sheet1.Range("D" & j).Value
Sheet1.Range("B" & j).Value = Sheet1.Range("E" & j).Value
Do Until Sheet1.Range("E" & i).Value = ""
    If Sheet1.Range("D" & i).Value = Sheet1.Range("D" & i - 1).Value Then
        Sheet1.Range("B" & j).Value = Sheet1.Range("B" & j).Value & ", " & Sheet1.Range("E" & i).Value
    Else
        j = j + 1
        Sheet1.Range("A" & j).Value = Sheet1.Range("D" & i).Value
        Sheet1.Range("B" & j).Value = Sheet1.Range("E" & i).Value
    End If
    i = i + 1
Loop
End Sub

ptm0412 · 19/1/12

kyo đã viết:
kyo làm còn sơ sài, rất mong được mọi người góp ý

Do Loop như vậy là chuẩn rồi. Nhưng có 1 số ý kiến thế này:

1. Nếu vẫn đánh vào sheet từng ô một:
Sử dụng With - End With để khỏi lập đi lập lại sheet1.Range(...

2. Nên dùng mảng để tăng tốc độ.
Vì theo thuật toán trên, không chỉ đánh từng ô trong sheet, mà mỗi ô còn bị đánh mấy lần!

3. Có 2 dòng lệnh lập lại giống nhau bên ngoài Do và bên trong Do, có thể gộp hết vào trong Do?

SA_DQ · 19/1/12

Bài 2B giành cho các thành viên dưới 500 bài viết & chưa có bài trong topic này

Mình có bảng dữ liệu sau:

1|Cha | Con 2 |AA|01
3 |AA|03
4 |AA|08
5 |AA|09
5| AA|10
6 |AA|A1
7 |CC|GPE
8 |BA|90
9 |BA|09
10| BA|10
11 |BA|A1
12 |BA|10
13|CC|Z1

Bằng macro nào để chuyển dữ liệu thành bảng sau:

| E | F 1 | Cha | Con 2 |AA|01, 03, 08, 09, 10, A1
3 |CC|GPE, Z1
4 |BA|90, 09, 10, A1, 10

(húc Mừng Xuân Mới!

kyo · 19/1/12

ptm0412 đã viết:
Do Loop như vậy là chuẩn rồi. Nhưng có 1 số ý kiến thế này:

1. Nếu vẫn đánh vào sheet từng ô một:
Sử dụng With - End With để khỏi lập đi lập lại sheet1.Range(...

2. Nên dùng mảng để tăng tốc độ.
Vì theo thuật toán trên, không chỉ đánh từng ô trong sheet, mà mỗi ô còn bị đánh mấy lần!

3. Có 2 dòng lệnh lập lại giống nhau bên ngoài Do và bên trong Do, có thể gộp hết vào trong Do?

Cám ơn chú đã góp ý cho con, con xin tiếp thu và sửa chữa. Về phần mảng thì con có hơi mù mờ với nó nên vẫn chưa có áp dụng nhiều, con sẽ cố gắng nghiên cứu nó.

Với bài tập tiếp theo, thuật toán có hơi dài một chút vì giờ kyo vẫn chưa nghĩ ra được thuật toán nào khác +-+-+-+

PHP:

Sub bt3()
Dim i As Integer, j As Integer, check As Boolean
i = 2
j = 1
With Sheet1
    .Range("E" & j).Value = .Range("A" & j).Value
    .Range("F" & j).Value = .Range("B" & j).Value
    Do Until .Range("B" & i).Value = ""
        If .Range("A" & i).Value = .Range("E" & j).Value Then
            .Range("F" & j).Value = .Range("F" & j).Value & ", " & .Range("B" & i).Value
        Else
            check = False
            EndR = .Range("E65000").End(xlUp).Row
            For j = 1 To EndR
                If .Range("A" & i).Value = .Range("E" & j).Value Then
                    .Range("F" & j).Value = .Range("F" & j).Value & ", " & .Range("B" & i).Value
                    check = True
                    Exit For
                End If
            Next j
            If check = False Then
                .Range("E" & j).Value = .Range("A" & i).Value
                .Range("F" & j).Value = .Range("B" & i).Value
            End If
        End If
        i = i + 1
    Loop
End With
End Sub

ChanhTQ@ · 19/1/12

Bài 2C hệt bài 2B đây ạ!

Có bảng dữ liệu sau:

1 | Cha | Con 2 |Hoa|Cúc
3 |Hoa|Mai
4 |Hoa|Đào
5 |Hoa|Hồng
5| Hoa|Táo
6 |Hoa|Thược dượt
7 |Mùa|Mưa
8 |Trái|Cam
9 |Trái|Quýt
10| Trái|Măng cụt
11 |Trái|Bưỡi
12 |Trái|Táo
13 |Mùa|Khô

Bằng macro nào để chuyển dữ liệu thành bảng sau:

| E | F 1 | Cha | Các con
2 |Hoa|Cúc, Mai, Đào, Hồng, Táo & Thược dượt
3 |Mùa|Mưa & Khô
4 |Trái|Cam, Quýt, Măng cụt, Bưỡi & Táo

(húc Mừng Xuân Mới!

ThuNghi · 20/1/12

kyo đã viết:

PHP:

Sub bt3()
Dim i As Integer, j As Integer, check As Boolean
i = 2
j = 1
With Sheet1
    .Range("E" & j).Value = .Range("A" & j).Value
    .Range("F" & j).Value = .Range("B" & j).Value
    Do Until .Range("B" & i).Value = ""
        If .Range("A" & i).Value = .Range("E" & j).Value Then
            .Range("F" & j).Value = .Range("F" & j).Value & ", " & .Range("B" & i).Value
        Else
            check = False
            EndR = .Range("E65000").End(xlUp).Row
            For j = 1 To EndR
                If .Range("A" & i).Value = .Range("E" & j).Value Then
                    .Range("F" & j).Value = .Range("F" & j).Value & ", " & .Range("B" & i).Value
                    check = True
                    Exit For
                End If
            Next j
            If check = False Then
                .Range("E" & j).Value = .Range("A" & i).Value
                .Range("F" & j).Value = .Range("B" & i).Value
            End If
        End If
        i = i + 1
    Loop
End With
End Sub

Những bài dạng thế này thì phải nghĩ ngay đến tạo 1 dm duy nhất ở cột Cha. Sau đó duyệt qua danh mục trên và lấy cột Con.
Mà dm duy nhất nếu chưa dùng Dic thì có thể dùng.
- Countif
- AdFilter. Theo tôi nên dùng cái này.

BNTT · 20/1/12

Hơ.... cái bác ThuNghi này... không đọc kỹ yêu cầu gì hết trơn.

giành cho các thành viên dưới 500 bài viết & chưa có bài trong topic này

ndu96081631 · 20/1/12

kyo đã viết:

Đây là bài 2

PHP:

Sub bt2()
Dim i As Integer, j As Integer
i = 2
j = 1
Sheet1.Range("A" & j).Value = Sheet1.Range("D" & j).Value
Sheet1.Range("B" & j).Value = Sheet1.Range("E" & j).Value
Do Until Sheet1.Range("E" & i).Value = ""
    If Sheet1.Range("D" & i).Value = Sheet1.Range("D" & i - 1).Value Then
        Sheet1.Range("B" & j).Value = Sheet1.Range("B" & j).Value & ", " & Sheet1.Range("E" & i).Value
    Else
        j = j + 1
        Sheet1.Range("A" & j).Value = Sheet1.Range("D" & i).Value
        Sheet1.Range("B" & j).Value = Sheet1.Range("E" & i).Value
    End If
    i = i + 1
Loop
End Sub

Với bài 2, dữ liệu không sort trước thì coi như code.. tèo
Dạng bài này phải dùng Dictionary mới chuẩn (đương nhiên phải kết hợp xử lý Array để tăng tốc)
----------------------

BNTT đã viết:
Hơ.... cái bác ThuNghi này... không đọc kỹ yêu cầu gì hết trơn.

Ông Piano này cũng... trên 4000 bài, vậy còn nói người ta
Ẹc... Ẹc...

ptm0412 · 20/1/12

ndu96081631 đã viết:
Với bài 2, dữ liệu không sort trước thì coi như code.. tèo
Dạng bài này phải dùng Dictionary mới chuẩn (đương nhiên phải kết hợp xử lý Array để tăng tốc)

Code Bt2() dựa vào đề bài 2 ndu ui, đề bài 2 là đã sort, đề 2B mới là chưa sort.

ndu96081631 · 20/1/12

ptm0412 đã viết:
Code Bt2() dựa vào đề bài 2 ndu ui, đề bài 2 là đã sort, đề 2B mới là chưa sort.

Em biết chứ! Nhưng đã làm thì phải tính đến mức tổng quát ---> dữ liệu thật có bao giờ "ngon ăn" thế đâu
Ẹc... Ẹc...

bebo021999 · 20/1/12

Bác HYen17 ơi, có bài tập nào cho thành viên từ 1500 bài trở lên không ạ? Tự đập đầu 3 cái +-+-+-+

SA_DQ · 20/1/12

Xin lỗi BeBo nghen!, Xin cụ thể hóa:

Giành cho những người có dưới 500 bài trong BOX lập trình & liên quan!

/-)ược chưa?

(húc xuân vui vẻ!

kyo · 20/1/12

kyo giải lại bài tập 2b nhưng xài Dic và mảng, có gì mong mọi người tiếp tục góp ý.

PHP:

Option Base 1
Sub bt2b()
Dim arr(), arrkq()
Dim EndR As Integer, i As Integer, j As Integer, r As Integer
With CreateObject("Scripting.Dictionary")
    j = 0
    r = 0
    EndR = Sheet1.Range("A65000").End(xlUp).Row
    ReDim arr(EndR - 1, 2)
    arr = Sheet1.Range("A2:B" & EndR).Value
    For i = 1 To UBound(arr)
        If Not .Exists(arr(i, 1)) Then
            .Add arr(i, 1), ""
            r = r + 1
            For j = 2 To EndR
                If Sheet1.Range("A" & j).Value = arr(i, 1) Then
                    ReDim Preserve arrkq(2, 1 To r)
                    arrkq(1, r) = arr(j - 1, 1)
                    If arrkq(2, r) = "" Then
                        arrkq(2, r) = arr(j - 1, 2)
                    Else
                        arrkq(2, r) = arrkq(2, r) & ", " & arr(j - 1, 2)
                    End If
                End If
            Next j
        End If
    Next i
    Sheet1.Range("E2").Resize(.Count, 2).Value = WorksheetFunction.Transpose(arrkq)
End With
End Sub

ptm0412 · 20/1/12

kyo đã viết:
kyo giải lại bài tập 2b nhưng xài Dic và mảng, có gì mong mọi người tiếp tục góp ý.

Thuật toán tạm ổn nhưng:
- Dùng 2 vòng lặp For lồng nhau, số lần lặp là bình phương số dòng dữ liệu. Nếu 2 vòng lặp riêng rẽ, số lần lặp là 2 x số dòng dữ liệu
- Nếu khéo, có thể dùng chỉ 1 vòng lặp, vừa tạo Dic, vừa gán kết quả. Số lần lặp vừa bằng số dòng dữ liệu.
- 1 trong 2 vòng lặp vẫn còn đọc cell, chưa đọc trên mảng
- Nên hạn chế dùng transpose.
- Nghiên cứu thêm về Dic.Item(key1)

paulsteigel · 20/1/12

Xin đóng góp một cách đơn giản mà không cần dùng đến mảng hay đối tượng ngoài nào cả. Tiếp cận này sử dụng chiến thuật xử lý tuần tự với một mẹo nhỏ - các bạn xem nhé...
(Mẹo ở đây là Với phần tử cha mới thì sẽ lưu vào biến nhớ theo dạng [cha mới]số dòng ghi kết quả tại sheet kết quả, sau đó khi duyệt lại thì chỉ dùng hàm instr để kiểm tra - giống dạng dùng dicobj thôi, nếu có thì lấy số dòng, nếu không thì lại cha mới, dòng mới)
(Các bác thông cảm - không phải vì tiêu chí 400 hay 500 bài đâu ạ), em chỉ xin chia sẻ một cách em hay dùng đối với chuỗi.

PHP:

Sub Test()
    Application.ScreenUpdating = False
    ' Cach lam theo huong xu ly tuan tu va mot chut meo
    ' Chuoi giu cac phan tu Cha va thu tu dong
    Dim PrcString As String, UseString As String, NewRow As Long, UseRow As Long
    ' Bien danh dau vi tri du lieu da ghi
    Dim xPos As Long
    ' Bien de giu vung duyet
    Dim ChkRange As Range
    Dim ShtSrc As Worksheet
    Dim ShtDst As Worksheet
    Set ShtSrc = Sheet1
    Set ShtDst = Sheet2
    Set ChkRange = ShtSrc.Range("A2")
    ' Dau tien, dong moi se bat dau tu dong 2
    NewRow = 2
    While ChkRange <> ""
        UseString = "[" & ChkRange & "]"
        xPos = InStr(PrcString, UseString)
        If xPos <= 0 Then
            ' Khong ton tai gia tri nay trong chuoi - chuyen sang dong moi va ghi nho dong
            ' Chuyen sang Sheet moi
            PrcString = PrcString & "," & UseString & NewRow
            ShtDst.Range("A" & NewRow) = ChkRange
            ShtDst.Range("B" & NewRow) = ChkRange.Offset(, 1)
            ' Tang dong moi
            NewRow = NewRow + 1
        Else
            ' Ok co trong cum du lieu da xu ly...
            UseRow = Val(Mid(PrcString, xPos + Len(UseString)))
            ShtDst.Range("A" & UseRow) = ChkRange
            ShtDst.Range("B" & UseRow) = ShtDst.Range("B" & UseRow) & ", " & ChkRange.Offset(, 1)
        End If
        Set ChkRange = ChkRange.Offset(1)
    Wend
    Set ChkRange = Nothing
    Set ShtDst = Nothing
    Set ShtSrc = Nothing
    Application.ScreenUpdating = True
End Sub

Thực ra bài giải này chỉ mang tính chất thí dụ về cách tiếp cận các loại đối tượng khác nhau. Việc sử dụng đối tượng nào trong bài toán phụ thuộc nhiều vào thói quen và yêu cầu xử lý của người dùng.
Chân thành cảm ơn các bác đã chú ý và chúc mọi người một cái tết an lành, thành công và hạnh phúc

ptm0412 · 20/1/12

Xin lỗi vì đã sửa php code trong bài của Paul, nó bị lỗi gì đó mà không xuống dòng.

Tiếp theo, xin nói ngay rằng, sử dụng mảng nhằm mục đích tăng tốc cho code.

Với kinh nghiệm đọc bài GPE, tôi thấy rằng với dữ liệu nhiều (trên 1000 dòng), việc đọc từng ô tên sheet, xử lý, rồi gán xuống từng ô, thời gian chạy code mất ít nhất là gấp đôi so với dùng mảng.

Nếu dữ liệu là 60.000 dòng, thời gian tiêu tốn gấp 8 đến 10 lần. (Có thể có sai số, tuỳ theo mức độ và số lượng công việc cần xử lý trước khi gán xuống)

ptm0412 · 20/1/12

Tôi vừa kiểm tra: Test với 13000 cha, 65.000 con:

- Code sử dụng Dictionary và 1 mảng, 2 vòng lặp riêng rẽ: 1.15 giây
- Code sử dụng Dictionary và 1 mảng, 1 vòng lặp: 1.06 giây
- Code của Paul: 76 giây. Hút 1/2 điếu thuốc.

SA_DQ · 21/1/12

Hơ.... cái bác ThuNghi này... không đọc kỹ yêu cầu gì hết trơn.

(hỉ cấm tham gia bài giải thôi, không cấm hướng dẫn hay gợi í đâu mừ!

/-)úng như ThuNghi nói, bài này có nhiều cách giải cho nhiều đối tượng khác nhau. Nhưng ngay bài giải đầu đã vô mức tương đối rồi, nên chúng ta sẽ khó thấy các bài giải mộc mạc khác . . . . .

Xin lỗi vì đã sửa php code trong bài của Paul, nó bị lỗi gì đó mà không xuống dòng.

Cái chuyện này có thể là lỗi của diễn đàn chúng ta; Mình từng gặp fải, một khi sửa chửa bài có xài [php ]. . .[/php] hay [code ]. . . [/code]

(húc )(uân &ui &ẻ!

nmhung49 · 21/1/12

Cuối năm rồi tham gia 1 bài coi kết thúc năm cũ mong năm sau mình sẽ tiếp bộ hơn, Chúc cả đại gia đình Giải Pháp Excel năm mới vui vẻ tràn đầy hạnh phúc!!!!!!!

PHP:

Sub chacon()
Dim dic As Object, iRow As Long, SourceArr As Variant
Dim RArr As Variant, i As Long
Set dic = CreateObject("Scripting.Dictionary")
SourceArr = Range("b2:c14").Value
ReDim RArr(1 To UBound(SourceArr, 1), 1 To UBound(SourceArr, 2))

    For iRow = 1 To UBound(SourceArr, 1)

        If Not dic.Exists(SourceArr(iRow, 1)) Then
            i = i + 1
            
            dic.Add SourceArr(iRow, 1), i
            RArr(i, 1) = SourceArr(iRow, 1)
            RArr(i, 2) = SourceArr(iRow, 2)
           
        Else
        
            RArr(dic.Item(SourceArr(iRow, 1)), 2) = RArr(dic.Item(SourceArr(iRow, 1)), 2) & ", " & SourceArr(iRow, 2)
        
        End If
        
    Next iRow

Range("d12").Resize(i, 2).Value = RArr
End Sub

ChanhTQ@ · 21/1/12

Xin fép bổ sung vài dòng lệnh thêm đẹp cửa nhà đón xuân!

NMHung49;373081= Cuối năm rồi, Chúc cả đại gia đình Giải Pháp Excel năm mới vui vẻ tràn đầy hạnh phúc!!!!!!!

PHP:

Option Explicit
Sub ChaCon()
 Dim Dic As Object, iRow As Long, SArr As Variant
 Dim RArr As Variant, i As Long, KqArr As Variant
1 Const Và As String = " & ":         Const DF As String = ", "

Set Dic = CreateObject("Scripting.Dictionary")
SArr = Range("b2:c14").Value
ReDim RArr(1 To UBound(SArr, 1), 1 To UBound(SArr, 2))
 For iRow = 1 To UBound(SArr, 1)
   If Not Dic.Exists(SArr(iRow, 1)) Then
         i = i + 1
         Dic.Add SArr(iRow, 1), i
         RArr(i, 1) = SArr(iRow, 1)
         RArr(i, 2) = SArr(iRow, 2)
   Else
5     If InStr(RArr(Dic.Item(SArr(iRow, 1)), 2), Và) Then _
         RArr(Dic.Item(SArr(iRow, 1)), 2) = Replace(RArr(Dic.Item(SArr(iRow, 1)), 2), Và, DF)
      RArr(Dic.Item(SArr(iRow, 1)), 2) = RArr(Dic.Item(SArr(iRow, 1)), 2) & Và & SArr(iRow, 2)
   End If
 Next iRow
 Range("E2").Resize(i, 2).Value = RArr
9 [e1].Value = [b1].Value:                 [F1].Value = "Các " & LCase([c1])
End Sub

ndu96081631 · 21/1/12

nmhung49 đã viết:

Cuối năm rồi tham gia 1 bài coi kết thúc năm cũ mong năm sau mình sẽ tiếp bộ hơn, Chúc cả đại gia đình Giải Pháp Excel năm mới vui vẻ tràn đầy hạnh phúc!!!!!!!

PHP:

Sub chacon()
Dim dic As Object, iRow As Long, SourceArr As Variant
Dim RArr As Variant, i As Long
Set dic = CreateObject("Scripting.Dictionary")
SourceArr = Range("b2:c14").Value
ReDim RArr(1 To UBound(SourceArr, 1), 1 To UBound(SourceArr, 2))

    For iRow = 1 To UBound(SourceArr, 1)

        If Not dic.Exists(SourceArr(iRow, 1)) Then
            i = i + 1
            
            dic.Add SourceArr(iRow, 1), i
            RArr(i, 1) = SourceArr(iRow, 1)
            RArr(i, 2) = SourceArr(iRow, 2)
           
        Else
        
            RArr(dic.Item(SourceArr(iRow, 1)), 2) = RArr(dic.Item(SourceArr(iRow, 1)), 2) & ", " & SourceArr(iRow, 2)
        
        End If
        
    Next iRow

Range("d12").Resize(i, 2).Value = RArr
End Sub

Thiếu 1 chổ quan trọng: Kiểm tra dữ liệu có rổng hay không?
Thí nghiệm thế này:
- Xóa dòng 4 và chạy code
- Xóa C2, C4 và C6 rồi chạy code
---------------
Kinh nghiệm của tôi khi làm việc với mảng:
- Đừng bao giờ dùng End(xlUp) để xác định cell cuối cùng ---> Nó sẽ sai nếu bảng tính có dùng AutoFilter ---> Cứ khai báo thừa ra cũng chẳng việc gì
- Nếu có thể được thì đừng bao giờ dùng các hàm của Excel cũng như các phép nối chuổi trong mảng ---> Nó là nguyên nhân gây chậm quá trình tính toán
- Sau khi thí nghiệm thành công cho mọi trường hợp, nên đưa dòng On Error Resume Next lên đầu code, vì dù có thí nghiệm kỹ đến đâu cũng sẽ có những sai sót không lường hết (đương nhiên, trong quá trình thí nghiệm ta đừng cho bẫy lỗi vào để còn biết lỗi phát sinh ở đâu)
vân... vân... và vân... vân...
Tóm lại: Thí nghiệm thật kỹ!

ptm0412 · 24/1/12

Bài tập cho những ai đã biết sử dụng Dic

Đầu năm khai bút GPE, không biết viết gì, buồn buồn ra bài tập mảng và Dic (khà khà)

Có dữ liệu như sau:

1,

|Tổ 1|Nhân viên 001|A001| |KH 001|

40.000,

|

2,

|Tổ 1|Nhân viên 001|A003| |KH 003|

20.000,

|

3,

|Tổ 1|Nhân viên 001|A004| |KH 004|

40.000,

|

4,

|Tổ 2|Nhân viên 002| |A002|KH 002|

6.000,

|

5,

|Tổ 2|Nhân viên 002|A005| |KH 005|

10.000,

|

6,

|Tổ 1|Nhân viên 001|A006| |KH 006|

10.000,

|

7,

|Tổ 2|Nhân viên 002| |A002|KH 002|

11.000,

|

8,

|Tổ 1|Nhân viên 001|A003| |KH 003|

25.000,

|

9,

|Tổ 1|Nhân viên 001|A007| |KH 007|

60.000,

|

Giả định:
- Một bộ phận nhiều nhân viên
- Một nhân viên phụ trtách nhiều khách hàng
- Một khách hàng chỉ do 1 nhân viên phụ trách.
- Dữ liệu nhập đúng và sort theo thời gian.

Câu 1:

Tổng hợp doanh thu của từng nhân viên theo mẫu:

ĐƠN VỊ

|

NV.QHKH

|

KH cá nhân

|

KH Doanh nghiệp

|
Tổ 1|Nhân viên 001|

195.000,

| |
Tổ 2|Nhân viên 002|

160.000,

|

17.000,

|
Tổ 2|Nhân viên 003|

64.000,

|

78.200,

|
Tổ 3|Nhân viên 005| |

55.000,

|
Tổ 3|Nhân viên 004|

50.600,

|

13.600,

|

Câu 2:

Tổng hợp doanh thu theo từng nhân viên, đồng thời đếm số lượng khách hàng có phát sinh doanh thu, theo mẫu:

ĐƠN VỊ

|

NV.QHKH

|

SL KH cá nhân

|

SL KH Doanh nghiệp

|

Dthu KH cá nhân

|

Dthu KH Doanh nghiệp

|
Tổ 1|Nhân viên 001|

5,

| |

195.000,

| |
Tổ 2|Nhân viên 002|

1,

|

1,

|

160.000,

|

17.000,

|
Tổ 2|Nhân viên 003|

1,

|

1,

|

64.000,

|

78.200,

|
Tổ 3|Nhân viên 005| |

2,

| |

55.000,

|
Tổ 3|Nhân viên 004|

1,

|

1,

|

50.600,

|

13.600,

|

Chú ý: tổng số 5 nhân viên, bán hàng 20 lượt, nhưng đếm số lượng khách hàng là 13, chia ra 2 loại.

Yêu cầu: Dùng mảng và Dic, không giới hạn thành viên tham gia.

ptm0412 · 30/1/12

Bài tập ế
11 lần tải, mấy chục lần đọc, mà không thấy phản hồi.

Câu 1 dễ òm à, còn câu 2 khi nào buộc chỉ dùng 1 vòng lặp mới khó thôi.

nmhung49 · 30/1/12

ptm0412 đã viết:
Bài tập ế
11 lần tải, mấy chục lần đọc, mà không thấy phản hồi.

Câu 1 dễ òm à, còn câu 2 khi nào buộc chỉ dùng 1 vòng lặp mới khó thôi.

Dạ bài này em xin đóng góp 1 đoạn code, vì em không thấy các Anh, Chị tham gia
Câu 1

PHP:

Sub Cau1()
Dim Dic1 As Object, iRow As Long, i As Long
Dim Arr() As Variant, TmpArr As Variant
With Sheets("Cau1")
 .Range("E4:H10").ClearContents
  Set Dic1 = CreateObject("Scripting.Dictionary")
    TmpArr = Sheet1.Range("b2:g21").Value
    ReDim Arr(1 To UBound(TmpArr, 1), 1 To 6)
    For iRow = 1 To UBound(TmpArr, 1)
        If Not IsEmpty(TmpArr(iRow, 2)) And Not Dic1.exists(TmpArr(iRow, 2)) Then
            i = i + 1
             Dic1.Add TmpArr(iRow, 2), i
             Arr(i, 1) = TmpArr(iRow, 1)
             Arr(i, 2) = TmpArr(iRow, 2)
            If TmpArr(iRow, 3) <> "" Then
                Arr(i, 3) = TmpArr(iRow, 6)
            Else
                Arr(i, 4) = TmpArr(iRow, 6)
            End If
        Else
            If TmpArr(iRow, 3) <> "" Then
                Arr(Dic1.Item(TmpArr(iRow, 2)), 3) = Arr(Dic1.Item(TmpArr(iRow, 2)), 3) + TmpArr(iRow, 6)
            Else
                
             Arr(Dic1.Item(TmpArr(iRow, 2)), 4) = Arr(Dic1.Item(TmpArr(iRow, 2)), 4) + TmpArr(iRow, 6)
                
            End If
        End If
    Next iRow
.Range("e4").Resize(i, 4).Value = Arr
End With
End Sub

Câu 2

PHP:

Sub Cau2()
Dim Dic1 As Object, Dic2 As Object, iRow As Long, i As Long, dem As Long
Dim Arr() As Variant, TmpArr As Variant, Tmp As Variant, Olddem As Long
With Sheets("Cau2")
 .Range("E21:F35").ClearContents
  Set Dic1 = CreateObject("Scripting.Dictionary")
  Set Dic2 = CreateObject("Scripting.Dictionary")
    TmpArr = Sheet1.Range("b2:g21").Value
    ReDim Arr(1 To UBound(TmpArr, 1), 1 To 6)
    dem = 0
    For iRow = 1 To UBound(TmpArr, 1)
    Tmp = TmpArr(iRow, 2) & TmpArr(iRow, 5)
    Olddem = dem
        If Not IsEmpty(Tmp) And Not Dic2.exists(Tmp) Then
                dem = dem + 1
                Dic2.Add Tmp, dem
                
        End If
        If Not IsEmpty(TmpArr(iRow, 2)) And Not Dic1.exists(TmpArr(iRow, 2)) Then
            i = i + 1
            
             Dic1.Add TmpArr(iRow, 2), i
             Arr(i, 1) = TmpArr(iRow, 1)
             Arr(i, 2) = TmpArr(iRow, 2)
            If TmpArr(iRow, 3) <> "" Then
                Arr(i, 5) = TmpArr(iRow, 6)
                Arr(i, 3) = 1
            Else
                Arr(i, 6) = TmpArr(iRow, 6)
                Arr(i, 4) = 1
            End If
        Else
            If TmpArr(iRow, 3) <> "" Then
                Arr(Dic1.Item(TmpArr(iRow, 2)), 5) = Arr(Dic1.Item(TmpArr(iRow, 2)), 5) + TmpArr(iRow, 6)
                If Olddem <> dem Then Arr(Dic1.Item(TmpArr(iRow, 2)), 3) = Arr(Dic1.Item(TmpArr(iRow, 2)), 3) + 1
            Else
                
                Arr(Dic1.Item(TmpArr(iRow, 2)), 6) = Arr(Dic1.Item(TmpArr(iRow, 2)), 6) + TmpArr(iRow, 6)
                If Olddem <> dem Then Arr(Dic1.Item(TmpArr(iRow, 2)), 4) = Arr(Dic1.Item(TmpArr(iRow, 2)), 4) + 1
            End If
        End If
    Next iRow
.Range("a21").Resize(i, 6).Value = Arr
End With
End Sub

Em xin cảm ơn Thầy Mỹ đã chỉ dẫn. Thanks Thầy thật nhiều, Mong các bạn và Anh, Chị góp ý thêm /-*+/

ptm0412 · 30/1/12

Cả 2 bài đều chuẩn. Cứ như nmhung đọc bài giải trước vậy? Nhất là câu 2, dùng 2 Dic và dùng 2 biến đếm cũ và mới.

Nhưng sao đặt tên biến nghe cứ kỳ kỳ thế nào ấy? OldDem? tiếng nước nào đây?

nmhung cho hỏi nhỏ 1 câu: Có câu 1 rồi, làm câu 2 mất bao nhiêu lâu?

nmhung49 · 31/1/12

ptm0412 đã viết:
Cả 2 bài đều chuẩn. Cứ như nmhung đọc bài giải trước vậy? Nhất là câu 2, dùng 2 Dic và dùng 2 biến đếm cũ và mới.

Nhưng sao đặt tên biến nghe cứ kỳ kỳ thế nào ấy? OldDem? tiếng nước nào đây?

nmhung cho hỏi nhỏ 1 câu: Có câu 1 rồi, làm câu 2 mất bao nhiêu lâu?

Câu 2 em làm đâu có ra đâu sư phụ chỉ đó mà còn hỏi nữa ta!!!!, lâu lâu đặt tên biến cho nó lạ đó mà he...he... chứ đâu có tiếng nước nào đâu Anh với Việt pha lộn he...he...

ndu96081631 · 31/1/12

ptm0412 đã viết:
Bài tập ế
11 lần tải, mấy chục lần đọc, mà không thấy phản hồi.

Câu 1 dễ òm à, còn câu 2 khi nào buộc chỉ dùng 1 vòng lặp mới khó thôi.

Ẹc... Ẹc... đúng là.. quá ế luôn
Sư phụ đã nói "CHẤP HẾT" rồi

ptm0412 đã viết:
không giới hạn thành viên tham gia.

vậy mà chẳng "ma" nào tham gia
Tái bút: khi nào hổng ai làm thì em sẽ... Ẹc... Ẹc... nhưng mà nói thiệt, em cũng bắt đầu thấy nhàm chán với mấy bài dạng này rồi
__--__

ptm0412 · 31/1/12

À nhớ ra rồi, đề bài này lấy từ file thực của Hùng mà mình đã làm trước đó.
Làm xong thấy hay hay về mặt suy luận logic nên để nguyên cấu trúc, đổi tên, thêm dữ liệu giả lập để thành bài tập.

Ẹc ẹc, vậy là tham gia giải bài đồng nghĩa với ăn gian đó nha.

ptm0412 · 31/1/12

ndu96081631 đã viết:
Ẹc... Ẹc... đúng là.. quá ế luôn

Tái bút: khi nào hổng ai làm thì em sẽ... Ẹc... Ẹc... nhưng mà nói thiệt, em cũng bắt đầu thấy nhàm chán với mấy bài dạng này rồi

Dùng Dic và mảng là dùng công cụ để thực hiện thuật toán (có thể dùng công cụ khác).
Sử dụng công cụ khéo hay không đó là Thủ thuật, thậm chi xảo thuật.

Trong khi đó, học lập trình thì quan trọng ở chỗ suy luận tìm ra thuật toán đúng.

Ai đó có thể thấy nhàm chán với công cụ này và tìm công cụ khác ngon hơn, nhanh hơn, ... Nhưng khi đã chán suy luận rồi thì tiêu đó nha. Mấy bài tập của mình đưa ra, hoặc những cách giải, toàn là những thí dụ về suy luận: Kể cả suy luận thông thường và suy luận khác thường.

Có thể Ndu sẽ có cách giải khác (thuật toán khác) hay hơn, vậy cứ đưa lên, lỡ ế rồi. (nmhung không tính, vì đó là bài giải của lão chết tiệt)

ndu96081631 · 31/1/12

ptm0412 đã viết:
Ai đó có thể thấy nhàm chán với công cụ này và tìm công cụ khác ngon hơn, nhanh hơn, ... Nhưng khi đã chán suy luận rồi thì tiêu đó nha. Mấy bài tập của mình đưa ra, hoặc những cách giải, toàn là những thí dụ về suy luận: Kể cả suy luận thông thường và suy luận khác thường.

Ah... không!
Ý em nói "chán" là "chán" mấy cái bài LỌC VÀ TỔNG HỢP DỮ LIỆU THEO ĐIỀU KIỆN ấy mà (chứ còn Dic và Array thì luôn là ưu tiên hàng đâu của em khi xử lý dữ liệu)
Ẹc... Ẹc...

ThuNghi · 31/1/12

ptm0412 đã viết:
Dùng Dic và mảng là dùng công cụ để thực hiện thuật toán (có thể dùng công cụ khác).
Sử dụng công cụ khéo hay không đó là Thủ thuật, thậm chi xảo thuật.

Trong khi đó, học lập trình thì quan trọng ở chỗ suy luận tìm ra thuật toán đúng.

Ai đó có thể thấy nhàm chán với công cụ này và tìm công cụ khác ngon hơn, nhanh hơn, ... Nhưng khi đã chán suy luận rồi thì tiêu đó nha. Mấy bài tập của mình đưa ra, hoặc những cách giải, toàn là những thí dụ về suy luận: Kể cả suy luận thông thường và suy luận khác thường.

Có thể Ndu sẽ có cách giải khác (thuật toán khác) hay hơn, vậy cứ đưa lên, lỡ ế rồi. (nmhung không tính, vì đó là bài giải của lão chết tiệt)

Em thi dùng cách khác một chút, còn nhanh hơn hay chậm hơn thì chưa biết.
Theo em thì em hiểu cách của em hơn.

PHP:

Sub Cau2Dic()
Dim endR&, i&, s&, nR&
Dim Tmp1$, Tmp2$
Dim Arr(), ArrKq()
Dim Dic1 As Object, Dic2 As Object
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheets("Data")
  endR = .Cells(65000, 1).End(3).Row
  Arr = .Range("B2:G" & endR).Value
End With
ReDim ArrKq(1 To UBound(Arr), 1 To 6)
For i = 1 To UBound(Arr)
  If Len(Arr(i, 1)) > 0 Then
    If Len(Arr(i, 2)) > 0 Then
      Tmp1 = Arr(i, 1) & Arr(i, 2)
      If Not Dic1.Exists(Tmp1) Then
        s = s + 1
        Dic1.Add Tmp1, s
        ArrKq(s, 1) = Arr(i, 1)
        ArrKq(s, 2) = Arr(i, 2)
      End If
      nR = Dic1.Item(Tmp1)
      Select Case Len(Arr(i, 3))
        Case Is > 0
          Tmp2 = Tmp1 & Arr(i, 3) & Arr(i, 4)
          If Not Dic2.Exists(Tmp2) Then
            Dic2.Add Tmp2, Nothing
            ArrKq(nR, 3) = ArrKq(nR, 3) + 1
          End If
          ArrKq(nR, 5) = ArrKq(nR, 5) + Arr(i, 6)
        Case Else
          Tmp2 = Tmp1 & vbBack & Arr(i, 4)
          If Not Dic2.Exists(Tmp2) Then
            Dic2.Add Tmp2, Nothing
            ArrKq(nR, 4) = ArrKq(nR, 4) + 1
          End If
          ArrKq(nR, 6) = ArrKq(nR, 6) + Arr(i, 6)
      End Select
    End If
  End If
Next i
If s > 0 Then
  With Sheets("Cau2")
    With .[A4]
      .Resize(1000, 6).ClearContents
      .Resize(s, 6) = ArrKq
    End With
  End With
End If
Erase Arr(), ArrKq()
Set Dic1 = Nothing: Set Dic2 = Nothing
End Sub

ptm0412 · 31/1/12

Bài giải gốc của câu 2: (viết gọn hơn nmhung, dù sao thì Hùng đã hiểu và làm lại đúng thuật toán và ứng dụng Dic đúng cách)

PHP:

Sub BaiTapVBA()
    Dim Dic1, Dic2, sArr, rArr, k, OldK, i, s, nR, EndR
    OldK = 0: k = 0
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
    With Sheet1
        If .AutoFilterMode = True Then .AutoFilterMode = False
        EndR = .[a65000].End(xlUp).Row
        sArr = .[B2].Resize(EndR - 1, 6).Value
    End With
    ReDim rArr(1 To EndR - 1, 1 To 6)
        For i = 1 To UBound(sArr)
            OldK = k
            If Not Dic2.exists(sArr(i, 3) & sArr(i, 4)) Then
                k = k + 1
                Dic2.Add sArr(i, 3) & sArr(i, 4), k
            End If
            If Not Dic1.exists(sArr(i, 1) & sArr(i, 2)) Then
                s = s + 1
                Dic1.Add sArr(i, 1) & sArr(i, 2), s
                rArr(s, 1) = sArr(i, 1): rArr(s, 2) = sArr(i, 2)
                If sArr(i, 3) <> "" Then
                    rArr(s, 5) = sArr(i, 6)
                    rArr(s, 3) = 1
                Else
                    rArr(s, 6) = sArr(i, 6)
                    rArr(s, 4) = 1
                End If
            Else
                nR = Dic1.Item(sArr(i, 1) & sArr(i, 2))
                If sArr(i, 3) <> "" Then
                    rArr(nR, 5) = rArr(nR, 5) + sArr(i, 6)
                    If OldK <> k Then rArr(nR, 3) = rArr(nR, 3) + 1
                Else
                    rArr(nR, 6) = rArr(nR, 6) + sArr(i, 6)
                    If OldK <> k Then rArr(nR, 4) = rArr(nR, 4) + 1
                End If
             End If
        Next
    Sheet2.[A4].Resize(s, 6) = rArr

End Sub

Nói chung code Thu Nghi và code trên cùng thuật toán:

- Tạo 2 danh sách duy nhất của nhân viên và của khách hàng
- Nếu gặp nhân viên mới, add vào danh sách và doanh thu bằng doanh thu dòng đó
- Nếu gặp mã KH mới, tăng thêm 1 và gán vào cột đếm tương ứng.
- Nếu gặp mã nhân viên đã có, cộng doanh thu vào tổng doanh thu tương ứng
- Nếu gặp mã KH đã có, không cộng thêm.

Về công cụ:
- Đều dùng 2 Dic, mỗi Dic là 1 danh sách duy nhất cho nhân viên và khách hàng

Sự khác biệt 2 code nằm ở thủ thuật sử dụng Dic và sắp xếp code:

- Code của ptm0412, dùng 1 biến đếm danh sách KH để đánh dấu, khi biến này thay đổi (Oldk < k) nghĩa là có thêm 1 KH mới chưa có trong danh sách, thì cộng thêm 1, không thì thôi. Do đó, code Add cho Dic2 chỉ viết 1 lần ở đầu vòng lặp

- Code của ThuNghi, không dựa vào biến đếm, nên câu lệnh Add cho Dic2 phải viết 2 lần trong cấu trúc If, dù chỉ chạy 1 ltrong 2 lần đó.

Hoàng Trọng Nghĩa · 31/1/12

ptm0412 đã viết:
Bài giải gốc của câu 2: (viết gọn hơn nmhung, dù sao thì Hùng đã hiểu và làm lại đúng thuật toán và ứng dụng Dic đúng cách)

Mã:

Sub BaiTapVBA() Dim Dic1, Dic2, sArr, rArr, k, OldK, i, s, nR, EndR OldK = 0: k = 0 Set Dic1 = CreateObject("Scripting.Dictionary") Set Dic2 = CreateObject("Scripting.Dictionary") With Sheet1 [B] If .AutoFilterMode = True Then .AutoFilterMode = False[/B] EndR = .[a65000].End(xlUp).Row sArr = .[B2].Resize(EndR - 1, 6).Value End With ......................................... End Sub

Chotter:

Nếu không muốn nó có Filter, Sư phụ cứ cho nó False chứ cần gì phải IF! ẹc ẹc ...

Mã:

    With Sheet1
       [B][COLOR=#ff0000] .AutoFilterMode = False[/COLOR][/B]
        EndR = .[a65000].End(xlUp).Row
        sArr = .[B2].Resize(EndR - 1, 6).Value
    End With

ptm0412 · 31/1/12

Những câu lệnh dạng này tập thói quen cẩn thận vẫn hơn. Gặp trường hợp khác biết đâu không được như vậy.

Phanhanhdai · 31/1/12

Nếu thay thế hàm Vlookup trong Excel bằng VBA thì cách làm thế nào

Bài toán của em có yêu cầu là điền cột đơn giá tại Sheet1 vào Sheet 2. Nếu bài này làm bằng Excel đơn thuần dùng hàm Vlookup là đơn giản nhất.

Bản thân em muốn tìm thêm cách giải bài này bằng VBA thì cách làm ra sao, em nghĩ mãi chưa ra, xin được chỉ dùm em./.

ndu96081631 · 31/1/12

Phanhanhdai đã viết:
Bài toán của em có yêu cầu là điền cột đơn giá tại Sheet1 vào Sheet 2. Nếu bài này làm bằng Excel đơn thuần dùng hàm Vlookup là đơn giản nhất.

Bản thân em muốn tìm thêm cách giải bài này bằng VBA thì cách làm ra sao, em nghĩ mãi chưa ra, xin được chỉ dùm em./.

Code thế này xem

PHP:

Public Dic As Object
Sub DienDG()
  Dim pList, sArray, tmp1 As String, tmp2 As Double, i As Long, j As Long
  On Error Resume Next
  If Dic Is Nothing Then
    Set Dic = CreateObject("Scripting.Dictionary")
    pList = Sheet1.Range("A2:B1000").Value
    For i = 1 To UBound(pList, 1)
      If pList(i, 1) <> "" Then
        tmp1 = CStr(pList(i, 1))
        tmp2 = CDbl(pList(i, 2))
        If Not Dic.Exists(tmp1) Then Dic.Add tmp1, tmp2
      End If
    Next
  End If
  With Sheet2.Range("A2:E10000")
    sArray = .Value
    For i = 1 To UBound(sArray, 1)
      If sArray(i, 1) <> "" Then
        sArray(i, 4) = Dic.Item(CStr(sArray(i, 2)))
        sArray(i, 5) = sArray(i, 3) * sArray(i, 4)
      End If
    Next
    .Value = sArray
  End With
End Sub

Lưu ý: Code chỉ đúng với cấu trúc dữ liệu như trong file của bạn. Nếu dữ liệu thật có khác hơn, bạn phải tự mình chỉnh lấy

trungvdb · 1/2/12

Mong thày, các anh chị giúp em hiểu thêm về lý thuyết Scripting.Dictionary, cái này em chưa được rõ cho lắm.

ThuNghi · 2/2/12

ptm0412 đã viết:
Bài giải gốc của câu 2: (viết gọn hơn nmhung, dù sao thì Hùng đã hiểu và làm lại đúng thuật toán và ứng dụng Dic đúng cách)

Nói chung code Thu Nghi và code trên cùng thuật toán:

- Tạo 2 danh sách duy nhất của nhân viên và của khách hàng
- Nếu gặp nhân viên mới, add vào danh sách và doanh thu bằng doanh thu dòng đó
- Nếu gặp mã KH mới, tăng thêm 1 và gán vào cột đếm tương ứng.
- Nếu gặp mã nhân viên đã có, cộng doanh thu vào tổng doanh thu tương ứng
- Nếu gặp mã KH đã có, không cộng thêm.

Về công cụ:
- Đều dùng 2 Dic, mỗi Dic là 1 danh sách duy nhất cho nhân viên và khách hàng
...

Em thử dùng 1 Dic và dùng thêm Instr thấy với dữ liệu # 60.000 records thì thấy nhanh hơn dùng 2 Dic

PHP:

Sub Cau2Dic1()
Dim T As Double
T = Timer
Dim endR&, i&, s&, nR&
Dim Tmp1$
Dim Arr(), ArrKq()
Dim Dic1 As Object
Set Dic1 = CreateObject("Scripting.Dictionary")
With Sheets("Data")
  endR = .Cells(65000, 1).End(3).Row
  Arr = .Range("B2:G" & endR).Value
End With
ReDim ArrKq(1 To UBound(Arr), 1 To 8)
For i = 1 To UBound(Arr)
  If Len(Arr(i, 1)) > 0 Then
    If Len(Arr(i, 2)) > 0 Then
      Tmp1 = Arr(i, 1) & Arr(i, 2)
      If Not Dic1.exists(Tmp1) Then
        s = s + 1
        Dic1.Add Tmp1, s
        ArrKq(s, 1) = Arr(i, 1)
        ArrKq(s, 2) = Arr(i, 2)
      End If
      nR = Dic1.Item(Tmp1)
      Select Case Len(Arr(i, 3))
        Case Is > 0
          If Len(ArrKq(nR, 7)) = 0 Then
            ArrKq(nR, 7) = Arr(i, 3) 'Add vao
            ArrKq(nR, 3) = ArrKq(nR, 3) + 1
            ArrKq(nR, 5) = ArrKq(nR, 5) + Arr(i, 6)
          Else
            If InStr(ArrKq(nR, 7), Arr(i, 3)) Then
              ArrKq(nR, 5) = ArrKq(nR, 5) + Arr(i, 6)
            Else
              ArrKq(nR, 7) = ArrKq(nR, 7) & Arr(i, 3) 'Add vao
              ArrKq(nR, 3) = ArrKq(nR, 3) + 1
              ArrKq(nR, 5) = ArrKq(nR, 5) + Arr(i, 6)
            End If
          End If
        Case Is = 0
          If Len(ArrKq(nR, 8)) = 0 Then
            ArrKq(nR, 8) = Arr(i, 4) 'Add vao
            ArrKq(nR, 4) = ArrKq(nR, 4) + 1
            ArrKq(nR, 6) = ArrKq(nR, 6) + Arr(i, 6)
          Else
            If InStr(ArrKq(nR, 8), Arr(i, 4)) Then
              ArrKq(nR, 6) = ArrKq(nR, 6) + Arr(i, 6)
            Else
              ArrKq(nR, 8) = ArrKq(nR, 8) & Arr(i, 4) 'Add vao
              ArrKq(nR, 4) = ArrKq(nR, 4) + 1
              ArrKq(nR, 6) = ArrKq(nR, 6) + Arr(i, 6)
            End If
          End If
      End Select
    End If
  End If
Next i
If s > 0 Then
  With Sheets("Cau2")
    With .[A4]
      .Resize(60000, 6).ClearContents
      .Resize(s, 6) = ArrKq
    End With
    .[I3] = Timer - T
  End With
End If
Erase Arr(), ArrKq()
Set Dic1 = Nothing
End Sub

ptm0412 · 2/2/12

Test 60.000 dòng nhưng test với dữ liệu mẫu nào mới được?

Thuật toán dùng Instr tức là nối chuỗi và tìm trong chuỗi. Vậy phải giả lập dữ liệu dạng nối chuỗi dài. Chẳng hạn như 50 nhân viên, mỗi nhân viên quản lý 100 khách hàng (tức là nối 100 chuỗi thành 1). Chứ cũng 5 nhân viên và 13 khách hàng, mỗi nhân viên quản lý tối đa 5 KH, nối tối đa 5 chuỗi là 20 ký tự, thì làm sao thấy ưu khuyết?

Vì bản thân thuật toán nối chuỗi và Instr là chậm. Hãy xem bài của Paulstiegel số #16, đã test tốc độ trong bài tiếp theo.

trungvdb · 3/2/12

Tôi đang tìm hiểu về Dictionary, tìm hiểu mãi nhưng không thấy chỗ nào nói về CStr, CDbl,Item trong đoạn Code sau là gì? Rất mong nhận được sự trợ giúp của mọi người.

PHP:

Public Dic As Object
Sub DienDG()
  Dim pList, sArray, tmp1 As String, tmp2 As Double, i As Long, j As Long
  On Error Resume Next
  If Dic Is Nothing Then
    Set Dic = CreateObject("Scripting.Dictionary")
    pList = Sheet1.Range("A2:B1000").Value
    For i = 1 To UBound(pList, 1)
      If pList(i, 1) <> "" Then
        tmp1 = CStr(pList(i, 1))
        tmp2 = CDbl(pList(i, 2))
        If Not Dic.Exists(tmp1) Then Dic.Add tmp1, tmp2
      End If
    Next
  End If
  With Sheet2.Range("A2:E10000")
    sArray = .Value
    For i = 1 To UBound(sArray, 1)
      If sArray(i, 1) <> "" Then
        sArray(i, 4) = Dic.Item(CStr(sArray(i, 2)))
        sArray(i, 5) = sArray(i, 3) * sArray(i, 4)
      End If
    Next
    .Value = sArray
  End With
End Sub

viehoai · 3/2/12

trungvdb đã viết:

Tôi đang tìm hiểu về Dictionary, tìm hiểu mãi nhưng không thấy chỗ nào nói về CStr, CDbl,Item trong đoạn Code sau là gì? Rất mong nhận được sự trợ giúp của mọi người.

PHP:

Public Dic As Object
Sub DienDG()
  Dim pList, sArray, tmp1 As String, tmp2 As Double, i As Long, j As Long
  On Error Resume Next
  If Dic Is Nothing Then
    Set Dic = CreateObject("Scripting.Dictionary")
    pList = Sheet1.Range("A2:B1000").Value
    For i = 1 To UBound(pList, 1)
      If pList(i, 1) <> "" Then
        tmp1 = CStr(pList(i, 1))
        tmp2 = CDbl(pList(i, 2))
        If Not Dic.Exists(tmp1) Then Dic.Add tmp1, tmp2
      End If
    Next
  End If
  With Sheet2.Range("A2:E10000")
    sArray = .Value
    For i = 1 To UBound(sArray, 1)
      If sArray(i, 1) <> "" Then
        sArray(i, 4) = Dic.Item(CStr(sArray(i, 2)))
        sArray(i, 5) = sArray(i, 3) * sArray(i, 4)
      End If
    Next
    .Value = sArray
  End With
End Sub

Hàm CStr() là hàm chuyển đổi sang kiểu String
Hàm CDbl() là hàm chuyển đổi biểu thức sang dạng số kiểu Double VD: CDbl(8*3) sẽ cho kết quả 24

nmhung49 · 3/2/12

trungvdb đã viết:
Tôi đang tìm hiểu về Dictionary, tìm hiểu mãi nhưng không thấy chỗ nào nói về CStr, CDbl,Item trong đoạn Code sau là gì? Rất mong nhận được sự trợ giúp của mọi người.

Item là phương thức của Dictionay nó dùng để truy xuất phần tử thứ item trong Keys của Dictionary, Cstr dùng để chuyển đổi số thành chuỗi mà dùng để so sánh trong VBA Code thôi ta không thể chuyển chúng thành chuỗi rồi gán xuống sheet dạng text được, tương tự CDbl chuyển chuỗi thành số vài lời cùng bạn

ndu96081631 · 3/2/12

viehoai đã viết:
Hàm CStr() là hàm chuyển đổi sang kiểu String
Hàm CDbl() là hàm chuyển đổi biểu thức sang dạng số kiểu Double VD: CDbl(8*3) sẽ cho kết quả 24

Mấy bạn ở trên đã nói về ý nghĩa của CStr và CDbl rồi.. tôi xin nói thêm tại sao phải dùng mấy "thằng" này
Là do không chắc dữ liệu trên sheet có chuẩn hay không... Nhiều khi thấy rõ ràng là số mà thật ra nó lại là Text... Vì thế nếu cho dữ liệu vào CStr thì ăn chắc nó sẽ chuyển thành Text và khi vào CDbl thì ăn chắc nó sẽ chuyển thành kiểu số (Double)
(kinh nghiệm xương máu khi làm việc với dữ liệu ngày tháng)

trungvdb · 3/2/12

Tôi mới phỏng đoán được ý nghĩa của đoạn sArray(i, 4) = Dic.Item(CStr(sArray(i, 2))) nhưng chưa biết chính xác của nó "dịch ra" nghĩa là thế nào? Xin trợ giúp để tôi có thể hiểu hơn.

Xin trân trọng cảm ơn.

ndu96081631 · 3/2/12

trungvdb đã viết:
Tôi mới phỏng đoán được ý nghĩa của đoạn sArray(i, 4) = Dic.Item(CStr(sArray(i, 2))) nhưng chưa biết chính xác của nó "dịch ra" nghĩa là thế nào? Xin trợ giúp để tôi có thể hiểu hơn.

Xin trân trọng cảm ơn.

Ví dụ cho dễ hiểu
Ta có quy tắc Add Dic như sau: Dic.Add Key, Item ---> Trong nhóm Keys không có em nào trùng (Items sao cũng được)

Mã:

Dic.Add "a", 5
Dic.Add "b", 11
Dic.Add "c", 15

Vậy để truy xuất Item của Key "b", ta dùng Dic.Item("b") ---> Kết quả = 11
Giống VLOOKUP ấy

trungvdb · 3/2/12

Cảm ơn bác Ndu nhé, cái Dic của bác quả là độc đáo. Cứ bài toán nào dính đến trích lọc duy nhất thì ta sử dụng Dic là tối ưu nhất rồi.

thanhlanh · 11/1/13

Baì tập số ...
Cho bảng dữ liệu như hình :

Yêu cầu:
1. Cột F: KQ lọc duy nhất danh sách các công ty, Cột G: doanh thu cao nhất của công ty đó.
2. Xử lý dữ liệu hoàn toàn trên mảng nhưng chỉ được sử dụng tối đa 1 mảng, 1 Dic, 1 vòng lặp.
(Tương tự như Consolidate của Excel).

----------------------------------------------
Bổ sung: Mảng chỉ được phép xử dụng (chép, đọc) một lần

File mẫu:

dhn46 · 11/1/13

thanhlanh đã viết:
Baì tập số ...
Yêu cầu:
1. Cột F: KQ lọc duy nhất danh sách các công ty, Cột G: doanh thu cao nhất của công ty đó.
2. Xử lý dữ liệu hoàn toàn trên mảng nhưng chỉ được sử dụng tối đa 1 mảng, 1 Dic, 1 vòng lặp.
(Tương tự như Consolidate của Excel).
File mẫu:

Dhn46 xin nộp bài (trong bài dùng 2 mảng trong đó có 1 mảng để lấy dữ liệu nguồn không biết có được chấp nhận hay không?)

Mã:

Sub Gpe()
Dim i As Long, k As Long, Arr, ArrKq, Dic As Object
Arr = Range("B2:D" & Range("B65536").End(3).Row)
ReDim ArrKq(1 To UBound(Arr, 1), 1 To 2)
MsgBox UBound(Arr)
Set Dic = CreateObject("scripting.dictionary")
With Dic
    For i = 1 To UBound(Arr, 1)
        If Not .exists(Arr(i, 1)) Then
            k = k + 1
            .Add Arr(i, 1), k
            ArrKq(k, 1) = Arr(i, 1)
            ArrKq(k, 2) = Arr(i, 3)
        Else
            If ArrKq(.Item(Arr(i, 1)), 2) < Arr(i, 3) Then ArrKq(.Item(Arr(i, 1)), 2) = Arr(i, 3)
        End If
    Next
End With
[F2].Resize(UBound(ArrKq, 1), 2) = ArrKq
End Sub

thanhlanh · 11/1/13

dhn46 đã viết:

Dhn46 xin nộp bài (trong bài dùng 2 mảng trong đó có 1 mảng để lấy dữ liệu nguồn không biết có được chấp nhận hay không?)

Mã:

Sub Gpe()
Dim i As Long, k As Long, Arr, ArrKq, Dic As Object
Arr = Range("B2:D" & Range("B65536").End(3).Row)
ReDim ArrKq(1 To UBound(Arr, 1), 1 To 2)
MsgBox UBound(Arr)
Set Dic = CreateObject("scripting.dictionary")
With Dic
    For i = 1 To UBound(Arr, 1)
        If Not .exists(Arr(i, 1)) Then
            k = k + 1
            .Add Arr(i, 1), k
            ArrKq(k, 1) = Arr(i, 1)
            ArrKq(k, 2) = Arr(i, 3)
        Else
            If ArrKq(.Item(Arr(i, 1)), 2) < Arr(i, 3) Then ArrKq(.Item(Arr(i, 1)), 2) = Arr(i, 3)
        End If
    Next
End With
[F2].Resize(UBound(ArrKq, 1), 2) = ArrKq
End Sub

Khoong hợp lệ, chỉ duy nhất một mảng

dhn46 · 11/1/13

Vậy thì sửa lại chút ạ

Mã:

Sub Gpe()
Dim i As Long, k As Long, Arr, Dic As Object
Arr = Range("B2:D" & Range("B65536").End(3).Row)
Set Dic = CreateObject("scripting.dictionary")
With Dic
    For i = 1 To UBound(Arr, 1)
        If Not .exists(Arr(i, 1)) Then
            k = k + 1
            .Add Arr(i, 1), k
            Arr(k, 1) = Arr(i, 1)
            Arr(k, 2) = Arr(i, 3)
        Else
            If Arr(.Item(Arr(i, 1)), 2) < Arr(i, 3) Then Arr(.Item(Arr(i, 1)), 2) = Arr(i, 3)
        End If
    Next
End With
[F2].Resize(k, 2) = Arr
End Sub

1 mảng Arr, 1 Dic, 1 vòng lặp For... Next

thanhlanh · 11/1/13

Cũng được nhưng chưa đúng ý đồ của mình lắm. Thôi thêm một ràng buộc nữa: mảng chỉ được phép xử dụng (gán, đọc) một lần

Ba Tê · 11/1/13

thanhlanh đã viết:
Cũng được nhưng chưa đúng ý đồ của mình lắm. Thôi thêm một ràng buộc nữa: mảng chỉ được phép xử dụng (gán, đọc) một lần

Thất nghiệp, Làm thử cái này xem sao.

PHP:

Dim Dic As Object, Arr(), I As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
For I = 1 To UBound(Arr, 1)
    Tem = Arr(I, 1)
    If Not Dic.Exists(Tem) Then
        K = K + 1
        Dic.Add Tem, Arr(I, 3)
    Else
        If Dic.Item(Tem) < Arr(I, 3) Then Dic.Item(Tem) = Arr(I, 3)
    End If
Next I
With Application.WorksheetFunction
[F2].Resize(K).Value = .Transpose(Dic.Keys)
[G2].Resize(K).Value = .Transpose(Dic.Items)
End With
Set Dic = Nothing
End Sub

thanhlanh · 11/1/13

Ba Tê đã viết:

Thất nghiệp, Làm thử cái này xem sao.

PHP:

Dim Dic As Object, Arr(), I As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
For I = 1 To UBound(Arr, 1)
    Tem = Arr(I, 1)
    If Not Dic.Exists(Tem) Then
        K = K + 1
        Dic.Add Tem, Arr(I, 3)
    Else
        If Dic.Item(Tem) < Arr(I, 3) Then Dic.Item(Tem) = Arr(I, 3)
    End If
Next I
With Application.WorksheetFunction
[F2].Resize(K).Value = .Transpose(Dic.Keys)
[G2].Resize(K).Value = .Transpose(Dic.Items)
End With
Set Dic = Nothing
End Sub

Cảm ơn anh, bây giờ mình tăng độ khó lên một tí: Không cho dùng .Exists của Dictionary nữa. và đó mới là ý đồ của tôi. Định ra bài cho mấy em "trẻ" nhưng toàn cao thủ như anh thì yêu cầu phải cao lên chứ. Ẹc ...ẹc! (Thấy bác Cò đang lấp ló, vào tham gia cho vui và để anh em học hỏi bác)

dhn46 · 11/1/13

- Bài bác Ba Tê vận dụng Dictionary hay quá! Lại học được 1 cái hay nữa rồi.
- @Bác ThanhLanh: Yêu cầu tiếp theo của bài tập không cho dùng .Exists của Dictionary thì ý đồ chủ đạo ở đây là dùng gì nhỉ? Vì dhn46 nghĩ nếu không dùng .Exists của Dictionary thì chỉ cần bỏ if đoạn đó và thêm (On Error Resume Next) là được.
- Bác có thể hướng mọi người theo 1 cách được không ạ?

thanhlanh · 11/1/13

dhn46 đã viết:
- Bài bác Ba Tê vận dụng Dictionary hay quá! Lại học được 1 cái hay nữa rồi.
- @Bác ThanhLanh: Yêu cầu tiếp theo của bài tập không cho dùng .Exists của Dictionary thì ý đồ chủ đạo ở đây là dùng gì nhỉ? Vì dhn46 nghĩ nếu không dùng .Exists của Dictionary thì chỉ cần bỏ if đoạn đó và thêm (On Error Resume Next) là được.

Không chơi với Error luôn!
Cố lên!

dhn46 đã viết:
- Bác có thể hướng mọi người theo 1 cách được không ạ?

Thì Bác Ba làm gần đúng rồi đó.

Quang_Hải · 11/1/13

dhn46 đã viết:
- Bài bác Ba Tê vận dụng Dictionary hay quá! Lại học được 1 cái hay nữa rồi.
- @Bác ThanhLanh: Yêu cầu tiếp theo của bài tập không cho dùng .Exists của Dictionary thì ý đồ chủ đạo ở đây là dùng gì nhỉ? Vì dhn46 nghĩ nếu không dùng .Exists của Dictionary thì chỉ cần bỏ if đoạn đó và thêm (On Error Resume Next) là được.
- Bác có thể hướng mọi người theo 1 cách được không ạ?

Nếu không dùng .Exists thì khi xuất hiện 1 key tồn tại sẽ báo lỗi. Ta có thể bẫy lỗi thế này If Error = 0 then... Else ...End If
PS : Đoán vậy thôi chứ chưa thử nữa nha

dhn46 · 11/1/13

Như vậy là vấn đề đã được giải quyết.
Mấu chốt vấn đề ở đây là ở điểm MyDictionary.Add Key, Item :
Item ở đây có thể không là duy nhất nên ta được phép gán các giá trị trong mảng vào
- Nếu tận dụng thêm thuộc tính .Count của dic nữa thì chắc không cần tới biến k

Cảm ơn các bác đã giúp dhn46 biết thêm 1 cái hay
(Ndu096091631 đã có mặt và đây là lần đầu tiên thấy nick này màu xanh =>Smod. Chúc mừng thầy!)

thanhlanh · 11/1/13

Các bạn thử đi!. Cố lên! (kỳ này mà mình làm sai chắc bị ném đá tơi bời, hic!)

Quang_Hải · 11/1/13

thanhlanh đã viết:
Các bạn thử đi!. Cố lên! (kỳ này mà mình làm sai chắc bị ném đá tơi bời, hic!)

Mình nói rồi chẳng có gì khó cả. Nếu khó quá thì bỏ chạy vậy thôi
Mượn code của anh Bate xài

PHP:

Sub vuivuivui()
Dim Arr(), I As Long, Tem As String
Arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
   With CreateObject("Scripting.Dictionary")
      For I = 1 To UBound(Arr, 1)
          Tem = Arr(I, 1)
          If Error = 0 Then
              Dic.Add Tem, Arr(I, 3)
          Else
              If .Item(Tem) < Arr(I, 3) Then .Item(Tem) = Arr(I, 3)
          End If
      Next I
      [F2].Resize(.Count).Value = Application.Transpose(.Keys)
      [G2].Resize(.Count).Value = Application.Transpose(.Items)
   End With
End Sub

ndu96081631 · 11/1/13

Muốn thì thì nghiệm (dùng Item Property)

Mã:

Sub Test()
  Dim Dic As Object
  Set Dic = CreateObject("Scripting.Dictionary")
  Dic.Add "a", "aa"
  Dic.Add "b", "bb"
  Dic.Add "c", "cc"
  MsgBox TypeName(Dic.Item("[COLOR=#ff0000]d[/COLOR]"))
End Sub

Kiểm tra cái chưa có trong Dic xem nó ra cái gì?

dhn46 · 11/1/13

Mượn Code bác Bate em nộp bài tiếp

Mã:

Sub a()
Dim Dic As Object, Arr(), i As Long, k As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
For i = 1 To UBound(Arr, 1)
    Tem = Arr(i, 1)
    If IsNull(Dic.Item(Tem)) Then
        k = k + 1
        Dic.Add Tem, Arr(i, 3)
    Else
        If Dic.Item(Tem) < Arr(i, 3) Then Dic.Item(Tem) = Arr(i, 3)
    End If
Next i
With Application.WorksheetFunction
[F2].Resize(Dic.Count).Value = .Transpose(Dic.keys)
[G2].Resize(Dic.Count).Value = .Transpose(Dic.Items)
End With
Set Dic = Nothing
End Sub

thanhlanh · 11/1/13

Mod xóa giùm bài này, do mạng trục trặc bấm nhầm hai lần.

thanhlanh · 11/1/13

dhn46 đã viết:

Mượn Code bác Bate em nộp bài tiếp

Mã:

Sub a()
Dim Dic As Object, Arr(), i As Long, k As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
For i = 1 To UBound(Arr, 1)
    Tem = Arr(i, 1)
    If IsNull(Dic.Item(Tem)) Then
        k = k + 1
        Dic.Add Tem, Arr(i, 3)
    Else
        If Dic.Item(Tem) < Arr(i, 3) Then Dic.Item(Tem) = Arr(i, 3)
    End If
Next i
With Application.WorksheetFunction
[F2].Resize(Dic.Count).Value = .Transpose(Dic.keys)
[G2].Resize(Dic.Count).Value = .Transpose(Dic.Items)
End With
Set Dic = Nothing
End Sub

Theo yêu cầu của mình thì Bạn đã đạt. Cảm ơn!
Bây giờ mình không muốn cho dùng cả .Exits và .Add của Dictionary luôn. Các bạn thử xem!

thanhlanh · 11/1/13

quanghai1969 đã viết:

Mình nói rồi chẳng có gì khó cả. Nếu khó quá thì bỏ chạy vậy thôi
Mượn code của anh Bate xài

PHP:

Sub vuivuivui()
Dim Arr(), I As Long, Tem As String
Arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
   With CreateObject("Scripting.Dictionary")
      For I = 1 To UBound(Arr, 1)
          Tem = Arr(I, 1)
          If Error = 0 Then
              Dic.Add Tem, Arr(I, 3)
          Else
              If .Item(Tem) < Arr(I, 3) Then .Item(Tem) = Arr(I, 3)
          End If
      Next I
      [F2].Resize(.Count).Value = Application.Transpose(.Keys)
      [G2].Resize(.Count).Value = Application.Transpose(.Items)
   End With
End Sub

Không được chơi vs Error nha!

Quang_Hải · 11/1/13

Không cho xài Error thì thôi không xài. Đã nói là không gì làm khó được mà

PHP:

Sub vuivui()
Dim Arr(), i As Long, tem As String
Arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
   With CreateObject("Scripting.Dictionary")
      For i = 1 To UBound(Arr, 1)
         tem = Arr(i, 1)
         If IsEmpty(.Item(tem)) Then
            .Item(tem) = Arr(i, 3)
         Else
            If .Item(tem) < Arr(i, 3) Then .Item(tem) = Arr(i, 3)
         End If
      Next i
      [F2].Resize(.Count).Value = Application.Transpose(.Keys)
      [G2].Resize(.Count).Value = Application.Transpose(.Items)
   End With
End Sub

thanhlanh · 11/1/13

quanghai1969 đã viết:

Không cho xài Error thì thôi không xài. Đã nói là không gì làm khó được mà

PHP:

Sub vuivui()
Dim Arr(), i As Long, tem As String
Arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
   With CreateObject("Scripting.Dictionary")
      For i = 1 To UBound(Arr, 1)
         tem = Arr(i, 1)
         If IsEmpty(.Item(tem)) Then
            .Item(tem) = Arr(i, 3)
         Else
            If .Item(tem) < Arr(i, 3) Then .Item(tem) = Arr(i, 3)
         End If
      Next i
      [F2].Resize(.Count).Value = Application.Transpose(.Keys)
      [G2].Resize(.Count).Value = Application.Transpose(.Items)
   End With
End Sub

Ok!
Còn đây là code của mình:

Mã:

Sub LocMax()
    Dim r As Long, arr(), dic As Object
    With ThisWorkbook.Worksheets("Sheet1")
        .Range("F1", .Cells(.Rows.Count - 1, "G").End(xlUp)).Offset(1).Clear
        arr = .Range("B2", .Cells(.Rows.Count, "D").End(xlUp)).Value
        Set dic = CreateObject("Scripting.Dictionary")
        For r = 1 To UBound(arr, 1)
            If dic.Item(arr(r, 1)) = "" Then dic.Item(arr(r, 1)) = arr(r, 3)
            If arr(r, 3) > dic.Item(arr(r, 1)) Then dic.Item(arr(r, 1)) = arr(r, 3)
        Next
        .Range("F2").Resize(dic.Count, 1).Value = Application.Transpose(dic.Keys)
        .Range("G2").Resize(dic.Count, 1).Value = Application.Transpose(dic.Items)
        .Range("F2:G11").Sort Key1:=.Range("F2"), Order1:=xlAscending, Header:=xlNo
    End With
    Set dic = Nothing
End Sub

Qua bài này mình muốn thực hành cùng các bạn để hiểu sâu hơn về Dictionary và vận dụng, nếu cần:
- Khi gán giá trị cho một Item của key chưa tồn tại thì Dictionary sẽ tự tạo một Key và một Item mới
For r = 1 To UBound(arr, 1)
dic.Item(arr(r, 1)) = arr(r, 3)
- Khi truy cập một Item của Key chưa tồn tại thì Dictionary cũng sẽ tự tạo một Key và một Item mới (rỗng).
For r = 1 To UBound(arr, 1)
If dic.Item(arr(r, 1)) = "" Then hoặc gán: i = dic.Item(arr(r, 1))

Quang_Hải · 11/1/13

Đã mần thì mần thêm cái anh Remove luôn

PHP:

Sub Key_Remove()
Dim arr(), i As Long, tem As String
arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
   With CreateObject("Scripting.Dictionary")
      For i = 1 To UBound(arr, 1)
         tem = arr(i, 1)
         If Not IsEmpty(.Item(tem)) Then
            If .Item(tem) < arr(i, 3) Then
               .Remove tem
               .Item(tem) = arr(i, 3)
            End If
         Else
            .Item(tem) = arr(i, 3)
         End If
      Next i
      [F2].Resize(.Count).Value = Application.Transpose(.Keys)
      [G2].Resize(.Count).Value = Application.Transpose(.Items)
   End With
End Sub

Bài này chủ yếu là mổ xẽ các phương thức và thuộc tính của Dictionary thôi. Tạm thời không chú ý đến những yếu tố khác

ndu96081631 · 11/1/13

thanhlanh đã viết:
Ok!
Còn đây là code của mình:

Mã:

Sub LocMax() Dim r As Long, arr(), dic As Object With ThisWorkbook.Worksheets("Sheet1") .Range("F1", .Cells(.Rows.Count - 1, "G").End(xlUp)).Offset(1).Clear arr = .Range("B2", .Cells(.Rows.Count, "D").End(xlUp)).Value Set dic = CreateObject("Scripting.Dictionary") For r = 1 To UBound(arr, 1) If dic.Item(arr(r, 1)) = "" Then dic.Item(arr(r, 1)) = arr(r, 3) If arr(r, 3) > dic.Item(arr(r, 1)) Then dic.Item(arr(r, 1)) = arr(r, 3) Next .Range("F2").Resize(dic.Count, 1).Value = Application.Transpose(dic.Keys) .Range("G2").Resize(dic.Count, 1).Value = Application.Transpose(dic.Items) .Range("F2:G11").Sort Key1:=.Range("F2"), Order1:=xlAscending, Header:=xlNo End With Set dic = Nothing End Sub

Qua bài này mình muốn thực hành cùng các bạn để hiểu sâu hơn về Dictionary và vận dụng, nếu cần:
- Khi gán giá trị cho một Item của key chưa tồn tại thì Dictionary sẽ tự tạo một Key và một Item mới
For r = 1 To UBound(arr, 1)
dic.Item(arr(r, 1)) = ""

- Khi truy cập một Item của Key chưa tồn tại thì Dictionary cũng sẽ tự tạo một Key và một Item mới.
For r = 1 To UBound(arr, 1)
dic.Item(arr(r, 1)) = arr(r, 3)

Bài này mà chơi WorksheetFunction.Transpose là vô cùng dở (ẹc) luôn ---> Sẽ bị lỗi nghiêm trọng đối với dữ liệu lớn
Em đề nghị kiểu khác: Gán Range vào mảng ---> Thay đổi giá trị mảng ---> gán mảng ngược lại

Mã:

Sub ConsolMAX()
  Dim aData, sTmp As String
  Dim lR As Long, n As Long, lMax As Double
  aData = Sheet1.Range("B2:D60000").Value
  With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For lR = 1 To UBound(aData)
      sTmp = CStr(aData(lR, 1))
      If Len(sTmp) Then
        If TypeName(.Item(sTmp)) = "Empty" Then
          n = n + 1
          .Item(sTmp) = n
          aData(n, 1) = sTmp
          aData(n, 2) = aData(lR, 3)
        Else
          lMax = aData(lR, 3)
          If lMax > aData(.Item(sTmp), 2) Then aData(.Item(sTmp), 2) = lMax
        End If
      End If
    Next
  End With
  If n Then
    With Sheet1.Range("F2:G60000")
      .ClearContents
      .Resize(n, 2).Value = aData
    End With
  End If
End Sub

60000 dòng ra kết quả trong vòng 0.5 giây
Ngoài ra code anh chưa tính vụ dữ liệu rổng nha!

thanhlanh · 11/1/13

Cảm ơn! nhưng mình chỉ chú trọng vào thực hành tính chất của Dic

ndu96081631 · 11/1/13

thanhlanh đã viết:
Cảm ơn! nhưng mình chỉ chú trọng vào thực hành tính chất của Dic

Vâng! Thì em cũng vậy
Nhưng mà bài này em thấy rất thực tế (nếu không muốn xài PivotTable) nên đã làm thì làm.. tới bến luôn chứ anh! (để ứng dụng)
Ẹc... Ẹc...

Ba Tê · 11/1/13

ndu96081631 đã viết:
Bài này mà chơi WorksheetFunction.Transpose là vô cùng dở (ẹc) luôn ---> Sẽ bị lỗi nghiêm trọng đối với dữ liệu lớn
Em đề nghị kiểu khác: Gán Range vào mảng ---> Thay đổi giá trị mảng ---> gán mảng ngược lại

Mã:

Sub ConsolMAX() Dim aData, sTmp As String Dim lR As Long, n As Long, lMax As Double aData = Sheet1.Range("B2:D60000").Value With CreateObject("Scripting.Dictionary") .CompareMode = vbTextCompare For lR = 1 To UBound(aData) sTmp = CStr(aData(lR, 1)) If Len(sTmp) Then If TypeName(.Item(sTmp)) = "Empty" Then n = n + 1 .Item(sTmp) = n aData(n, 1) = sTmp aData(n, 2) = aData(lR, 3) Else lMax = aData(lR, 3) If lMax > aData(.Item(sTmp), 2) Then aData(.Item(sTmp), 2) = lMax End If End If Next End With If n Then With Sheet1.Range("F2:G60000") .ClearContents .Resize(n, 2).Value = aData End With End If End Sub

60000 dòng ra kết quả trong vòng 0.5 giây
Ngoài ra code anh chưa tính vụ dữ liệu rổng nha!

Bài này với "luật lệ" của bài này thì có gì "phạm quy" hông ta?

thanhlanh đã viết:
Cũng được nhưng chưa đúng ý đồ của mình lắm. Thôi thêm một ràng buộc nữa: mảng chỉ được phép xử dụng (gán, đọc) một lần

mảng aData hình như bị đọc và gán lại hơn một lần!
Gán:

sTmp = CStr(aData(lR, 1))

Cái này hình như là đọc:

sTmp = CStr(aData(lR, 1))

Cái này hình như là gán lại:

aData(n, 1) = sTmp aData(n, 2) = aData(lR, 3)

Híc!
Hay lại say nữa rồi??!!..
Éc! Éc...

ndu96081631 · 12/1/13

Ba Tê đã viết:
Bài này với "luật lệ" của bài này thì có gì "phạm quy" hông ta?

mảng aData hình như bị đọc và gán lại hơn một lần!
Gán:

Cái này hình như là đọc:

Cái này hình như là gán lại:

Híc!
Hay lại say nữa rồi??!!..
Éc! Éc...

Cũng như anh thanhlanh đã nói

thanhlanh đã viết:
mình chỉ chú trọng vào thực hành tính chất của Dic

nên em chỉ quan tâm đến giải thuật xử lý trong Dictionary thôi, còn mảng thế nào không quan trọng. Thậm chí nên thêm 1 Array kết quả nữa sẽ tường minh hơn

thanhlanh · 12/1/13

Ba Tê đã viết:
Bài này với "luật lệ" của bài này thì có gì "phạm quy" hông ta?

mảng aData hình như bị đọc và gán lại hơn một lần!
Gán:

Cái này hình như là đọc:

Cái này hình như là gán lại:

Híc!
Hay lại say nữa rồi??!!..
Éc! Éc...

Mình đã thấy như vậy rồi, nhưng lúc đó mình đã công bố đáp án nên không ý kiến gì.

Với bài tập này, mình muốn thay đổi tư duy xử dụng Dictionary, chớ lâu nay mỗi khi tìm duy nhất là buộc phải dùng phương thức Exists. Ở đây ta có thêm một lựa chọn là có thể không dùng Exists và add mà vẫn giải quyết được. Chẳng hạn với yêu cầu đơn giản là lọc một danh sách có trùng thành một danh sách không trùng, không quan tâm giá trị khác thì chẳng cần Exists làm gì.

Bài của ndu được xem như một bài phản biện, góp ý chớ không phải bài thi ...

Sắp tới, cũng yêu cầu này mình cắt luôn không cho sài Dictionary, Collection nhưng cũng không phải sàng xê trên mảng để lọc hay tìm danh sách duy nhất (tất nhiên phải dùng mảng để "chứa dữ liệu" và trích xuất các giá trị khác). Nhưng nếu làm thì cũng chỉ là cho vui thôi nên sẽ chuyển bài qua mục đố vui. Các bạn nghiên cứu thử xem.

dhn46 · 12/1/13

Các thầy ra những bài tâph như thế này quả là bổ ích học được nhiều và hiểu sâu hơn VBA. Mong rằng các thầy ra nhiều nhiều bài nữa để bậc vỡ lòng tụi em còn mần Code (Các thầy có thể ra bài buổi tối hoặc kết thúc đáp án vào buổi tối được không vì ban ngày có thể tụi em không online được - Híc)

thanhlanh đã viết:
Sắp tới, cũng yêu cầu này mình cắt luôn không cho sài Dictionary, Collection nhưng cũng không phải sàng xê trên mảng để lọc hay tìm danh sách duy nhất (tất nhiên phải dùng mảng để "chứa dữ liệu" và trích xuất các giá trị khác). Nhưng nếu làm thì cũng chỉ là cho vui thôi nên sẽ chuyển bài qua mục đố vui. Các bạn nghiên cứu thử xem.

Về vấn đề trích lọc danh sách duy nhất không dùng Dic thì cũng đã được đề cập (Dhn46 nhớ không lầm thì trong Topic của bác TrungChinh về tách thửa đất) và phương pháp rất tối ưu của bác Cò đó là dùng Instr(...)

Chúc các thầy dồi dào sức khỏe và tích cực ra bài nữa.

ndu96081631 · 12/1/13

thanhlanh đã viết:
Mình đã thấy như vậy rồi, nhưng lúc đó mình đã công bố đáp án nên không ý kiến gì.

Với bài tập này, mình muốn thay đổi tư duy xử dụng Dictionary, chớ lâu nay mỗi khi tìm duy nhất là buộc phải dùng phương thức Exists. Ở đây ta có thêm một lựa chọn là có thể không dùng Exists và add mà vẫn giải quyết được. Chẳng hạn với yêu cầu đơn giản là lọc một danh sách có trùng thành một danh sách không trùng, không quan tâm giá trị khác thì chẳng cần Exists làm gì.

Bài của ndu được xem như một bài phản biện, góp ý chớ không phải bài thi ...

Sắp tới, cũng yêu cầu này mình cắt luôn không cho sài Dictionary, Collection nhưng cũng không phải sàng xê trên mảng để lọc hay tìm danh sách duy nhất (tất nhiên phải dùng mảng để "chứa dữ liệu" và trích xuất các giá trị khác). Nhưng nếu làm thì cũng chỉ là cho vui thôi nên sẽ chuyển bài qua mục đố vui. Các bạn nghiên cứu thử xem.

Tản mạn chút (rồi bị del cũng.. chịu)
Kiến thức về Dictionary, VBScript.RegExp, Array và 1 vài thứ khác tuy đã có nhiều trên diễn đàn trước khi mình tham gia, nhưng mình nhớ không lầm thì mình mới chính là người đầu tiên đưa những kiến thức đó tiếp cận với "giới bình dân"
Những tưởng đó là tuyệt chiêu của riêng, ai ngờ giờ đây bao nhiêu thành viên vận dụng nó còn "bén" hơn cả mình ---> Đến nỗi nhìn vào code của mọi người mình còn phải "lác mắt"
Híc... vậy là đến cuối cùng, mình.. đếch còn gì rồi
-----------------------------
Anh thanhlanh sao không đưa yêu cầu mới mà anh vừa nói lên đi (em cũng thấy tò mò)

thanhlanh · 12/1/13

dhn46 đã viết:
Các thầy ra những bài tâph như thế này quả là bổ ích học được nhiều và hiểu sâu hơn VBA. Mong rằng các thầy ra nhiều nhiều bài nữa để bậc vỡ lòng tụi em còn mần Code (Các thầy có thể ra bài buổi tối hoặc kết thúc đáp án vào buổi tối được không vì ban ngày có thể tụi em không online được - Híc)

Về vấn đề trích lọc danh sách duy nhất không dùng Dic thì cũng đã được đề cập (Dhn46 nhớ không lầm thì trong Topic của bác TrungChinh về tách thửa đất) và phương pháp rất tối ưu của bác Cò đó là dùng Instr(...)

Chúc các thầy dồi dào sức khỏe và tích cực ra bài nữa.

Nhưng nếu không dùng Dictionary hoặc Collection thì chắc phải sàng qua sàng lại trên mảng để tìm, mình không muốn vậy, thế nên mới gọi là vui chớ!

thanhlanh · 12/1/13

ndu96081631 đã viết:
Tản mạn chút (rồi bị del cũng.. chịu)
Kiến thức về Dictionary, VBScript.RegExp, Array và 1 vài thứ khác tuy đã có nhiều trên diễn đàn trước khi mình tham gia, nhưng mình nhớ không lầm thì mình mới chính là người đầu tiên đưa những kiến thức đó tiếp cận với "giới bình dân"
Những tưởng đó là tuyệt chiêu của riêng, ai ngờ giờ đây bao nhiêu thành viên vận dụng nó còn "bén" hơn cả mình ---> Đến nỗi nhìn vào code của mọi người mình còn phải "lác mắt"
Híc... vậy là đến cuối cùng, mình.. đếch còn gì rồi
-----------------------------
Anh thanhlanh sao không đưa yêu cầu mới mà anh vừa nói lên đi (em cũng thấy tò mò)

Hi hi đừng tự giày vò bản thân như thế, mình có đi tên lửa cũng chẳng bao giờ bằng ndu, vì cái chỉ số IQ gì đó nó quyết định.

Yêu cầu mới của mình cũng là giải bài này bằng mảng kết hợp Macro4 chơi nhưng cũng chưa xong, khi nào làm được thì sẽ giới thiệu, còn không được thì thôi chớ đừng ném đá nha!

Quang_Hải · 12/1/13

thanhlanh đã viết:
Hi hi đừng tự giày vò bản thân như thế, mình có đi tên lửa cũng chẳng bao giờ bằng ndu, vì cái chỉ số IQ gì đó nó quyết định.

Yêu cầu mới của mình cũng là giải bài này bằng mảng kết hợp Macro4 chơi nhưng cũng chưa xong, khi nào làm được thì sẽ giới thiệu, còn không được thì thôi chớ đừng ném đá nha!

Không cho xài Dic để lấy dữ liệu duy nhất thì xài mảng cũng xơi được. Cái macro4 gì đó mình không biết xài nên xử kiểu này thấy cũng đơn giản. Mình thuộc dạng liều mạng mà. Híc.

PHP:

Sub loc_duy_nhat_lay_max_khong_dung_dic()
Dim arr(), i As Long, result(), j As Long, n As Long, m As Long
arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
ReDim result(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
   For j = 1 To UBound(result)
      If arr(i, 1) = result(j, 1) Then
         If result(j, 2) < arr(i, 3) Then result(j, 2) = arr(i, 3)
         n = 0:         Exit For
      Else
         n = n + 1
      End If
   Next j
   If n Then
      m = m + 1
      result(m, 1) = arr(i, 1):      result(m, 2) = arr(i, 3)
   End If
Next
[H2].Resize(m, 2) = result
End Sub

ndu96081631 · 12/1/13

quanghai1969 đã viết:
Không cho xài Dic để lấy dữ liệu duy nhất thì xài mảng cũng xơi được. Cái macro4 gì đó mình không biết xài nên xử kiểu này thấy cũng đơn giản. Mình thuộc dạng liều mạng mà. Híc.

PHP:

Sub loc_duy_nhat_lay_max_khong_dung_dic() Dim arr(), i As Long, result(), j As Long, n As Long, m As Long arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value ReDim result(1 To UBound(arr), 1 To 2) For i = 1 To UBound(arr) For j = 1 To UBound(result) If arr(i, 1) = result(j, 1) Then If result(j, 2) < arr(i, 3) Then result(j, 2) = arr(i, 3) n = 0: Exit For Else n = n + 1 End If Next j If n Then m = m + 1 result(m, 1) = arr(i, 1): result(m, 2) = arr(i, 3) End If Next [H2].Resize(m, 2) = result End Sub

Giải thuật này gần giống với giải thuật sort mảng (thời xa xưa)... Cũng 2 vòng lập chạy đi chạy lại
Hic... dữ liệu 60000 dòng chắc phải đợi đi đám cưới của tungnguyen về hy vọng nó mới chạy xong!
Ẹc... Ẹc...

Quang_Hải · 12/1/13

ndu96081631 đã viết:
Giải thuật này gần giống với giải thuật sort mảng (thời xa xưa)... Cũng 2 vòng lập chạy đi chạy lại
Hic... dữ liệu 60000 dòng chắc phải đợi đi đám cưới của tungnguyen về hy vọng nó mới chạy xong!
Ẹc... Ẹc...

Em cũng biết vậy nhưng tại tìm giải thuật cho vui và để tập suy nghĩ thôi. Chứ ai tội gì tự làm khổ mình như thế này chứ.

Quang_Hải · 12/1/13

ndu96081631 đã viết:
Giải thuật này gần giống với giải thuật sort mảng (thời xa xưa)... Cũng 2 vòng lập chạy đi chạy lại
Hic... dữ liệu 60000 dòng chắc phải đợi đi đám cưới của tungnguyen về hy vọng nó mới chạy xong!
Ẹc... Ẹc...

Em chứng minh cho anh thấy rằng cách này em xử lý dữ liệu 65000 dòng trong 3 giây là xong
Đàn em của anh càng ngày càng bớt dốt rồi mà.

PHP:

Sub loc_duy_nhat_lay_max_khong_dung_dic()
Dim arr(), i As Long, result(), j As Long, n As Long, m As Long, result2()
Dim t As Double
t = Timer
arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
For i = 1 To UBound(arr)
      If m > 0 Then
         For j = 1 To m
            If arr(i, 1) = result(j) Then
               If result2(j) < arr(i, 3) Then result2(j) = arr(i, 3)
               n = 0:
               Exit For
            Else
               n = n + 1
            End If
         Next j
         If n Then
            m = m + 1
            ReDim Preserve result(1 To m)
            ReDim Preserve result2(1 To m)
            result(m) = arr(i, 1)
            result2(m) = arr(i, 3)
         End If
      Else
         m = m + 1
         ReDim Preserve result(1 To m)
         ReDim Preserve result2(1 To m)
         result(m) = arr(i, 1)
         result2(m) = arr(i, 3)
      End If
Next
[H2].Resize(m) = Application.Transpose(result)
[I2].Resize(m) = Application.Transpose(result2)
MsgBox Timer - t
End Sub

Nếu anh cho rằng Transpose không tốt thì em xin xài code này

PHP:

Sub loc_duy_nhat_lay_max_khong_dung_dic2()
Dim arr(), i As Long, result(1 To 10000, 1 To 1), j As Long, n As Long, m As Long, result2(1 To 10000, 1 To 1)
Dim t As Double
t = Timer
arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
For i = 1 To UBound(arr)
      If m > 0 Then
         For j = 1 To m
            If arr(i, 1) = result(j, 1) Then
               If result2(j, 1) < arr(i, 3) Then result2(j, 1) = arr(i, 3)
               n = 0:
               Exit For
            Else
               n = n + 1
            End If
         Next j
         If n Then
            m = m + 1
            result(m, 1) = arr(i, 1)
            result2(m, 1) = arr(i, 3)
         End If
      Else
         m = m + 1
         result(m, 1) = arr(i, 1)
         result2(m, 1) = arr(i, 3)
      End If
Next
[H2].Resize(m, 1) = result
[I2].Resize(m, 1) = result2
MsgBox Timer - t
End Sub

dhn46 · 12/1/13

Nếu chỉ dùng vòng lặp em cũng đóng góp 1 code

Mã:

Sub Gpe()
Dim i As Integer, arr, ArrKq, sArr, s As String
arr = Range("B2:D" & Range("B65536").End(3).Row)
For i = 1 To UBound(arr)
    If InStr(1, s, arr(i, 1)) = 0 Then
        s = s & arr(i, 1) & "-" & arr(i, 3) & ";"
    Else
        If Val(Mid(s, InStr(1, s, arr(i, 1)) + Len(arr(i, 1)) + 1, InStr(Right(s, Len(s) - InStr(1, s, arr(i, 1)) - 1), "-"))) < arr(i, 3) Then
            s = Replace(s, Mid(s, InStr(1, s, arr(i, 1)), InStr(Right(s, Len(s) - InStr(1, s, arr(i, 1))), ";")), arr(i, 1) & "-" & arr(i, 3))
        End If
    End If
Next
ReDim ArrKq(1 To UBound(arr), 1 To 2)


sArr = Split(";" & Left(s, Len(s) - 1), ";")
For i = 1 To UBound(sArr)
    ArrKq(i, 1) = Left(sArr(i), InStr(1, s, "-") - 1)
    ArrKq(i, 2) = Right(sArr(i), Len(sArr(i)) - Len(ArrKq(i, 1)) - 1)
Next
[f2].Resize(UBound(ArrKq), 2) = ArrKq
End Sub

--------------------------------------------
Ngồi rảnh e test Code với 65535 dòng trên cái máy tính cùi mà cho tốc độ khá quá : trên dưới 0.18 (s). Giải thuật này hay quá!

siwtom · 12/1/13

quanghai1969 đã viết:

PHP:

Sub loc_duy_nhat_lay_max_khong_dung_dic2()
Dim arr(), i As Long, result(1 To 10000, 1 To 1), j As Long, n As Long, m As Long, result2(1 To 10000, 1 To 1)
Dim t As Double
t = Timer
arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
For i = 1 To UBound(arr)
      If m > 0 Then
         For j = 1 To m
            If arr(i, 1) = result(j, 1) Then
               If result2(j, 1) < arr(i, 3) Then result2(j, 1) = arr(i, 3)
               n = 0:
               Exit For
            Else
               n = n + 1
            End If
         Next j
         If n Then
            m = m + 1
            result(m, 1) = arr(i, 1)
            result2(m, 1) = arr(i, 3)
         End If
      Else
         m = m + 1
         result(m, 1) = arr(i, 1)
         result2(m, 1) = arr(i, 3)
      End If
Next
[H2].Resize(m, 1) = result
[I2].Resize(m, 1) = result2
MsgBox Timer - t
End Sub

Nếu mảng arr có 10.000 dòng thì đk "IF m > 0 THEN" được tính 10.000 lần. Mà ta biết rằng chỉ trừ lần đầu còn 9.999 lần sau thì đk thỏa, vậy chả lý gì lại mất "điện nước" như thế nên tôi sửa thành.

[GPECODE=vb]
Sub loc_duy_nhat_lay_max_khong_dung_dic2()
Dim arr(), i As Long, result(1 To 10000, 1 To 1), j As Long, n As Long, m As Long, result2(1 To 10000, 1 To 1)
Dim t As Double
t = Timer
arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
m = 1
result(1, 1) = arr(1, 1)
result2(1, 1) = arr(1, 3)
For i = 2 To UBound(arr)
For j = 1 To m
If arr(i, 1) = result(j, 1) Then
If result2(j, 1) < arr(i, 3) Then result2(j, 1) = arr(i, 3)
n = 0:
Exit For
Else
n = n + 1
End If
Next j
If n Then
m = m + 1
result(m, 1) = arr(i, 1)
result2(m, 1) = arr(i, 3)
End If
Next
[H2].Resize(m, 1) = result
[I2].Resize(m, 1) = result2
MsgBox Timer - t
End Sub
[/GPECODE]

Nhìn kỹ thấy "n = n + 1" là hoàn toàn không cần thiết. Vậy sửa tiếp thành

[GPECODE=vb]
Sub loc_duy_nhat_lay_max_khong_dung_dic2()
Dim arr(), i As Long, result(1 To 10000, 1 To 1), j As Long, m As Long, result2(1 To 10000, 1 To 1)
Dim t As Double
t = Timer
arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
m = 1
result(1, 1) = arr(1, 1)
result2(1, 1) = arr(1, 3)
For i = 2 To UBound(arr)
For j = 1 To m
If arr(i, 1) = result(j, 1) Then
If result2(j, 1) < arr(i, 3) Then result2(j, 1) = arr(i, 3)
Exit For
End If
Next j
If j > m Then
m = m + 1
result(m, 1) = arr(i, 1)
result2(m, 1) = arr(i, 3)
End If
Next
[H2].Resize(m, 1) = result
[I2].Resize(m, 1) = result2
MsgBox Timer - t
End Sub
[/GPECODE]

Nếu không muốn dùng j cho đk "IF j > m THEN" thì

Mã:

Sub loc_duy_nhat_lay_max_khong_dung_dic2()
Dim arr(), i As Long, result(1 To 10000, 1 To 1), j As Long, n As Long, m As Long, result2(1 To 10000, 1 To 1)
Dim t As Double
    t = Timer
    arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value    
    m = 1
    result(1, 1) = arr(1, 1)
    result2(1, 1) = arr(1, 3)    
    For i = 2 To UBound(arr)
        For j = 1 To m
           If arr(i, 1) = result(j, 1) Then
              If result2(j, 1) < arr(i, 3) Then result2(j, 1) = arr(i, 3)
              [COLOR=#ff0000]n = 1[/COLOR]
              Exit For
           End If
        Next j
        If [COLOR=#ff0000]n < 1[/COLOR] Then
            m = m + 1
            result(m, 1) = arr(i, 1)
            result2(m, 1) = arr(i, 3)
        Else
            [COLOR=#ff0000]n = 0[/COLOR]
        End If
    Next
    [H2].Resize(m, 1) = result
    [I2].Resize(m, 1) = result2
    MsgBox Timer - t
End Sub

siwtom · 13/1/13

dhn46 đã viết:

Nếu chỉ dùng vòng lặp em cũng đóng góp 1 code

Mã:

Sub Gpe()
Dim i As Integer, arr, ArrKq, sArr, s As String
arr = Range("B2:D" & Range("B65536").End(3).Row)
For i = 1 To UBound(arr)
    If InStr(1, s, arr(i, 1)) = 0 Then
        s = s & arr(i, 1) & "-" & arr(i, 3) & ";"
    Else
        If Val(Mid(s, InStr(1, s, arr(i, 1)) + Len(arr(i, 1)) + 1, InStr(Right(s, Len(s) - InStr(1, s, arr(i, 1)) - 1), "-"))) < arr(i, 3) Then
            s = Replace(s, Mid(s, InStr(1, s, arr(i, 1)), InStr(Right(s, Len(s) - InStr(1, s, arr(i, 1))), ";")), arr(i, 1) & "-" & arr(i, 3))
        End If
    End If
Next
ReDim ArrKq(1 To UBound(arr), 1 To 2)


sArr = Split(";" & Left(s, Len(s) - 1), ";")
For i = 1 To UBound(sArr)
    ArrKq(i, 1) = Left(sArr(i), InStr(1, s, "-") - 1)
    ArrKq(i, 2) = Right(sArr(i), Len(sArr(i)) - Len(ArrKq(i, 1)) - 1)
Next
[f2].Resize(UBound(ArrKq), 2) = ArrKq
End Sub

--------------------------------------------
Ngồi rảnh e test Code với 65535 dòng trên cái máy tính cùi mà cho tốc độ khá quá : trên dưới 0.18 (s). Giải thuật này hay quá!

Bạn viết: "Ngồi rảnh e test Code", vậy tôi hiểu là code trên bạn copy từ VBE ra chứ chả nhẽ ngồi gõ lại từng dòng.
Nếu thế thì đúng là ấn tượng đấy. Bạn có thủ thuật nào mà code ở trên chạy được vậy?
Rõ ràng ta có Dim i As Integer, thế mà For i = 1 To UBound(arr) chạy "êm" thì cũng lạ.
Chả nhẽ bạn copy từ VBE ra rồi sửa lại Long thành Integer? Hơi khó tin, vì chả ai mua việc như thế.
Vậy bạn đã thao tác thế nào đây?
--------------
Về tốc độ cũng chưa ấn tượng lắm.
Bạn đo tốc độ code của quanghai chưa?
Chả nhẽ tôi test sai hay máy của tôi có vấn đề. Sự thật là code của quanghai chạy khoảng 60% thời gian code của bạn (cả hai đều 10 lần chạy). Trên máy tôi là khoảng 1 giây - 0,6 giây

to quanghai:
Bạn viết: "Em chứng minh cho anh thấy rằng cách này em xử lý dữ liệu 65000 dòng trong 3 giây là xong"

Tại sao trên máy tôi chỉ mất 0,6 giây? Máy tôi yếu mà 10 năm tuổi rồi.

Quang_Hải · 13/1/13

siwtom đã viết:
to quanghai:
Bạn viết: "Em chứng minh cho anh thấy rằng cách này em xử lý dữ liệu 65000 dòng trong 3 giây là xong"
Tại sao trên máy tôi chỉ mất 0,6 giây? Máy tôi yếu mà 10 năm tuổi rồi.

Thật ra trên máy tính của em chạy chỉ khoảng 1s +, nhưng em đâu có biết máy tính mọi người khác thế nào nên phải tăng lên như thế nghe cho hợp lý. Tính em vẫn thế, nếu khả năng mình làm được 10 chỉ nói là 5 thôi cho an toàn.

dhn46 · 13/1/13

siwtom đã viết:
Bạn viết: "Ngồi rảnh e test Code", vậy tôi hiểu là code trên bạn copy từ VBE ra chứ chả nhẽ ngồi gõ lại từng dòng.
Nếu thế thì đúng là ấn tượng đấy. Bạn có thủ thuật nào mà code ở trên chạy được vậy?
Rõ ràng ta có Dim i As Integer, thế mà For i = 1 To UBound(arr) chạy "êm" thì cũng lạ.
Chả nhẽ bạn copy từ VBE ra rồi sửa lại Long thành Integer? Hơi khó tin, vì chả ai mua việc như thế.
Vậy bạn đã thao tác thế nào đây?
--------------
Về tốc độ cũng chưa ấn tượng lắm.
Bạn đo tốc độ code của quanghai chưa?
Chả nhẽ tôi test sai hay máy của tôi có vấn đề. Sự thật là code của quanghai chạy khoảng 60% thời gian code của bạn (cả hai đều 10 lần chạy). Trên máy tôi là khoảng 1 giây - 0,6 giây

to quanghai:
Bạn viết: "Em chứng minh cho anh thấy rằng cách này em xử lý dữ liệu 65000 dòng trong 3 giây là xong"

Tại sao trên máy tôi chỉ mất 0,6 giây? Máy tôi yếu mà 10 năm tuổi rồi.

Cảm ơn bác SiwTom đã chỉ ra nhưng vấn đề Code dhn46. Dhn46 có 1 số giải thích và sửa đổi + chứng minh như sau:

A - Giải thích:
Thuật toán này dhn46 học được trên GPE và áp dụng tự viết cho bài này. Khi test Code thì dòng dữ liệu 65536 vẫn tồn tại dẫn tới test sai => Sơ suất đáng trách

B - Sửa đổi:
Ngồi voọc lại 1 chút thấy code của dhn46 có 1 chút vấn đề
1 - Đúng như bác Siwtom chỉ ra, i = integer là Sai vậy xin sửa thành Long
2 - Đoạn Code

Mã:

ArrKq(i, 1) = Left(sArr(i), InStr(1, s, "-") - 1)

sửa thành

Mã:

ArrKq(i, 1) = Left(sArr(i), InStr(1, sArr(i), "-") - 1)

C - Chứng minh:
Với các dữ liệu khác nhau và máy khác nhau thì cho các kết quả test khác nhau. Để thống nhất dhn46 đã làm 1 file test với 3 Code: dhn46 - quanghai -quanghai_editSiwtom. Và trên máy cùi bắp của dhn46(celeron2.4, ram 512) thì có kết quả test như File đính kèm => tốc độ dhn46 chỉ bằng 60% Code còn lại
Cảm ơn mọi người và mong nhận được sử chỉ giáo.

thanhlanh · 13/1/13

quanghai1969 đã viết:
Thật ra trên máy tính của em chạy chỉ khoảng 1s +, nhưng em đâu có biết máy tính mọi người khác thế nào nên phải tăng lên như thế nghe cho hợp lý. Tính em vẫn thế, nếu khả năng mình làm được 10 chỉ nói là 5 thôi cho an toàn.

Hi! Một kiểu khiêm tốn lạ.
Biết ngay là không có dic thì phải sàng xê trên mảng mà.
----------------------------
Như đã hứa mình giới thiệu một cách không dùng dic khác, để vọc cho vui thôi chớ không nên dùng nha (mới lạ, chạy chậm, code dài, không dùng được với các ký tự đặc biệt ....)

Mã:

Sub LocMax_Macro4()
    Dim k As Variant, Congty As String
    Dim r As Long, arr(), arrKQ()
    With ThisWorkbook.Worksheets("Sheet1")
        .Range("F1", .Cells(.Rows.Count, "G").End(xlUp)).Offset(1).Clear
        arr = .Range("B2", .Cells(.Rows.Count, "D").End(xlUp)).Value
        ReDim arrKQ(1 To UBound(arr, 1), 1 To 2)
        For r = 1 To UBound(arr, 1)
            If arr(r, 1) <> "" Then
                Congty = CStr(Replace(arr(r, 1), " ", "___"))
                k = GetName(Congty)
                If IsError(k) Then
                    i = i + 1
                    SetName Congty, i
                    arrKQ(i, 1) = Replace(Congty, "___", " ")
                    arrKQ(i, 2) = arr(r, 3)
                Else
                    If k <> Congty Then If arrKQ(k, 2) < arr(r, 3) Then arrKQ(k, 2) = arr(r, 3)    ': arrKQ(k, 1) = Congty
                End If
            End If
        Next
        .Range("F2").Resize(UBound(arrKQ, 1), 2).Value = arrKQ
        .Range("F2:G11").Sort Key1:=.Range("F2"), Order1:=xlAscending, Header:=xlNo
    End With
    For i = 1 To UBound(arrKQ, 1)
        Congty = Replace(arrKQ(i, 1), " ", "___")
        DelName Congty
    Next
End Sub

Các thủ tục, hàm kèm theo:

Mã:

Sub SetName(Name As String, Value)
    Application.ExecuteExcel4Macro "SET.NAME(""" & Name & """," & Value & ")"
End Sub
Function GetName(Name As String)
    GetName = Application.ExecuteExcel4Macro(Name)
End Function
Sub DelName(Name As String)
    Application.ExecuteExcel4Macro "SET.NAME(""" & Name & """)"
End Sub

Các thủ tục, hàm này dùng để tạo, đọc và xóa Name trong VBA (không phải Name trong Excel)
Các Name/biến được tạo theo cách này, nếu chưa có lệnh xóa thì nó sẽ được lưu giữ cho đến khi ta thoát Excel, dùng để lưu gía trị của biến công cộng thì tuyệt vời.

ndu96081631 · 13/1/13

quanghai1969 đã viết:
Em chứng minh cho anh thấy rằng cách này em xử lý dữ liệu 65000 dòng trong 3 giây là xong
Đàn em của anh càng ngày càng bớt dốt rồi mà.
-----------------------
Nếu anh cho rằng Transpose không tốt thì em xin xài code này

Rảnh ngồi xem lại cái (vì tôi KHÔNG TIN cái trong 3 giây ấy tí nào)
Thí nghiệm bằng cách gõ vào cell B2 chữ "Nguyễn 1" rồi kéo fill xuống đến hết (mục đích đếch cho thằng nào trùng) ---> Xong nhấn nút phát xong bao lâu nó ra kết quả
Ẹc... Ẹc...
-----------------
Tất cả những code khác cũng test theo kiểu dữ liệu mới này nhé ---> Nếu không phải bấm Ctrl + Alt + Del thì xin chúc mừng: Máy mạnh

Quang_Hải · 13/1/13

ndu96081631 đã viết:
Rảnh ngồi xem lại cái (vì tôi KHÔNG TIN cái trong 3 giây ấy tí nào)
Thí nghiệm bằng cách gõ vào cell B2 chữ "Nguyễn 1" rồi kéo fill xuống đến hết (mục đích đếch cho thằng nào trùng) ---> Xong nhấn nút phát xong bao lâu nó ra kết quả
Ẹc... Ẹc...
-----------------
Tất cả những code khác cũng test theo kiểu dữ liệu mới này nhé ---> Nếu không phải bấm Ctrl + Alt + Del thì xin chúc mừng: Máy mạnh

Với cách trên thì máy tính của em cũng cho ra kết quả là 3... nhưng không phải 3s mà là 3 phút. Chính xác là 180s+
Cũng với dữ liệu này thì dùng cách .Add thì máy tính em cho ra kết quả trong 1s+
Nhưng mà anh chơi kiểu này cũng ác quá.
Cấu hình CPU 2.5 x 4 RAM 4G

siwtom · 13/1/13

quanghai1969 đã viết:
Thật ra trên máy tính của em chạy chỉ khoảng 1s +, nhưng em đâu có biết máy tính mọi người khác thế nào nên phải tăng lên như thế nghe cho hợp lý. Tính em vẫn thế, nếu khả năng mình làm được 10 chỉ nói là 5 thôi cho an toàn.

À, hóa ra sửa đổi kết quả, giả mạo chứng từ văn bản ...

Tôi không ngạc nhiên cái chuyện 3 giây - 0,6 giây, có thể là 3 ngày - 0,6 ngày. Cái này nó phụ thuộc vào dữ liệu đầu vào và vào máy.

Cái tôi ngạc nhiên là tỉ lệ. Bởi nếu cùng dữ liệu đầu vào như thế như thế mà ở máy 10 tuổi của tôi lại chạy nhanh gấp 5 lần thì tôi thấy bất ngờ quá.

thanhlanh · 13/1/13

ndu96081631 đã viết:
Rảnh ngồi xem lại cái (vì tôi KHÔNG TIN cái trong 3 giây ấy tí nào)
Thí nghiệm bằng cách gõ vào cell B2 chữ "Nguyễn 1" rồi kéo fill xuống đến hết (mục đích đếch cho thằng nào trùng) ---> Xong nhấn nút phát xong bao lâu nó ra kết quả
Ẹc... Ẹc...
-----------------
Tất cả những code khác cũng test theo kiểu dữ liệu mới này nhé ---> Nếu không phải bấm Ctrl + Alt + Del thì xin chúc mừng: Máy mạnh

Mình test dữ liệu của Hải (64800 dòng) không cho thằng nào trùng, bằng code mình (có dùng dic) 15 lần thì hết 12 lần là 2.422s nhưng máy mình trung bình chớ không mạnh (E5400 2.7Ghz, Ram 2G).
Nếu hàm Transpose làm chậm thì cũng dùng có một lần, không sợ. Còn ndu nói hàm Transpose có thể gây lỗi thì ở trường hợp nào, chớ ở đây mảng mới luôn "ngắn" hơn hoặc bằng mảng cũ làm sao lỗi?

ndu96081631 · 13/1/13

thanhlanh đã viết:
Mình test dữ liệu của Hải (64800 dòng) không cho thằng nào trùng, bằng code mình (có dùng dic) 15 lần thì hết 12 lần là 2.422s nhưng máy mình trung bình chớ không mạnh (E5400 2.7Ghz, Ram 2G).

Ý em là muốn anh và các bạn khác thử code không dùng Dic với loại dữ liệu 65000 dòng không trùng xem nó chạy nỗi không
Bởi vậy mới nói: Dictionary là thứ chuyên trị về Unique, chúng ta khỏi mất công nghiên cứu lòng vòng chi cho mệt (trừ phi anh siwtom nghĩ ra được giải thuật nào khác)
Em nói thêm: Ngay cả khi dùng Dictionary nhưng cố tình không chơi phương thức Exists mà lại dùng Item property thì vẫn chậm hơn
Tóm lại: Dùng đúng công cụ, đúng cách luôn cho kết quả tốt nhất

thanhlanh đã viết:
Còn ndu nói hàm Transpose có thể gây lỗi thì ở trường hợp nào, chớ ở đây mảng mới luôn "ngắn" hơn hoặc bằng mảng cũ làm sao lỗi?

Trên diễn đàn mình đây thôi anh à, trước đây đã từng có vài lần bị lỗi với Transpose nên từ đó trở đi em không dùng nữa (thà rằng tự viết lấy hàm xoay mảng 90 độ còn hơn)... Với lại, ta hoàn toàn có thể xây dựng được mảng 2 chiều thì mắc mớ gì phải dùng mảng 1 chiều rồi lại phải mất công Transpose?

ndu96081631 · 13/1/13

quanghai1969 đã viết:
Với cách trên thì máy tính của em cũng cho ra kết quả là 3... nhưng không phải 3s mà là 3 phút. Chính xác là 180s+
Cũng với dữ liệu này thì dùng cách .Add thì máy tính em cho ra kết quả trong 1s+
Nhưng mà anh chơi kiểu này cũng ác quá.
Cấu hình CPU 2.5 x 4 RAM 4G

Cũng kiên nhẫn ghê!
Tôi chưa khi nào phải đợi code chạy quá 20s ----> Vốn nóng tính và ưa thích tốc độ nên.. Ctrl + Alt + Del cho rồi
Ẹc... ẹc...

dhn46 · 13/1/13

ndu96081631 đã viết:
Ý em là muốn anh và các bạn khác thử code không dùng Dic với loại dữ liệu 65000 dòng không trùng xem nó chạy nỗi không
Bởi vậy mới nói: Dictionary là thứ chuyên trị về Unique, chúng ta khỏi mất công nghiên cứu lòng vòng chi cho mệt (trừ phi anh siwtom nghĩ ra được giải thuật nào khác)
Em nói thêm: Ngay cả khi dùng Dictionary nhưng cố tình không chơi phương thức Exists mà lại dùng Item property thì vẫn chậm hơn
Tóm lại: Dùng đúng công cụ, đúng cách luôn cho kết quả tốt nhất

Thầy nói "Chuẩn" quá. đúng là với cái máy tính cùi như của em thì "Không thể Test" (đợi không nổi alt + ctrl + del luôn)với khối dữ liệu không trùng lớn khi không dùng Dic. Nhưng qua bài này e cũng thấy thú vị vì có nhiều cách, tư duy hay, nhưng em vẫn thắc mắc không hiểu thầy SiwTom test trên máy thầy ấy lại có kết quả lạ (máy tính em đang dùng chắc cũng 10 năm).

siwtom · 13/1/13

ndu96081631 đã viết:
Ý em là muốn anh và các bạn khác thử code không dùng Dic với loại dữ liệu 65000 dòng không trùng xem nó chạy nỗi không
Bởi vậy mới nói: Dictionary là thứ chuyên trị về Unique, chúng ta khỏi mất công nghiên cứu lòng vòng chi cho mệt (trừ phi anh siwtom nghĩ ra được giải thuật nào khác)
Em nói thêm: Ngay cả khi dùng Dictionary nhưng cố tình không chơi phương thức Exists mà lại dùng Item property thì vẫn chậm hơn
Tóm lại: Dùng đúng công cụ, đúng cách luôn cho kết quả tốt nhất

1. code chậm là đương nhiên. Ta nhìn vòng lặp thứ hai trong code của Hải. Nếu các dữ liệu không không trùng nhau thì Exit For sẽ không bao giờ sẩy ra, tức luôn có m vòng lặp. Mà m thì tăng liên tục từ 1 tới 64800

2. Tuấn chắc hiểu là không ai muốn tìm "công cụ" khác cả. Mọi người không dùng DIC, Exists, Add bởi đây là "bài đố" và người ra bài không cho phép dùng DIC, Exists, Add.

3. Có thể kiểm tra "trùng" nhưng không dùng cách chạy hết các phần tử của mảng kết quả như Hải đã làm trong FOR thứ hai. Tuy nhiên tôi cho rằng không thể nhanh hơn phương thức Exists của Dic được. Vì sao? Vì nói cho cùng thì thuật toán mình cần dùng cũng là một trong những thuật toán đã có trong lập trình nói chung.Có nhiều sách hoặc trang trên mạng chỉ nói về các thuật toán. Nhiều lắm.
Vậy nếu ta dùng một thuật toán được biết thì chả nhẽ Microsoft lại không biết? Khả năng cao hơn rất nhiều là "nó" còn biết những thuật toán mà mình không biết.

4. Tuấn để ý là tôi không tham gia dự thi. Vì tôi không thích lắm cái trò: đố làm được "cái này" mà không dùng DIC, không dùng Macro4, không dùng ...
Vì tôi biết là có đưa ra cách giải quyết thì nó cũng chỉ được dùng 1 lần trên "bàn nhậu" khi thách đố nhau thôi. Code "đó" sẽ không bao giờ được dùng trong thực tế.

Tôi sửa code của Hải trên nguyên tắc: "nếu đã viết code như thế thì cũng nên viết gọn hơn như thế này thế này".

Code của Hải chỉ là cái cớ để mình hướng dẫn cách phân tích và rút gọn code trong lập trình. Nó không phải là bài "dự thi" của siwtom, vì siwtom không dự thi. Vì siwtom không có ý định viết code chạy nhanh như DIC mà lại thay thế DIC.

ndu96081631 · 13/1/13

siwtom đã viết:
4. Tuấn để ý là tôi không tham gia dự thi. Vì tôi không thích lắm cái trò: đố làm được "cái này" mà không dùng DIC, không dùng Macro4, không dùng ...
Vì tôi biết là có đưa ra cách giải quyết thì nó cũng chỉ được dùng 1 lần trên "bàn nhậu" khi thách đố nhau thôi. Code "đó" sẽ không bao giờ được dùng trong thực tế.
.

Cái em quan tâm ở đây là: thằng Dictionary nó dùng thuật toán gì mà có thể Check Exists ngon lành vậy
Lúc đầu em nghĩ đến hàm StrPtr chuyển String thành Long và lấy giá trị Long này thiết lập vị trí trong mảng, đáng tiếc là thí nghiệm không thành công
Anh biết có hàm nào chuyển String thành Long không? Điều kiện là String khác nhau thì giá trị Long nhận được cũng phải khác nhau (đồng thời giá trị Long lớn nhất cũng không được lớn hơn 6 chữ số)
Nếu được như vậy thì giải pháp không còn là vấn đề

thanhlanh · 14/1/13

ndu96081631 đã viết:
Em nói thêm: Ngay cả khi dùng Dictionary nhưng cố tình không chơi phương thức Exists mà lại dùng Item property thì vẫn chậm hơn
Tóm lại: Dùng đúng công cụ, đúng cách luôn cho kết quả tốt nhất

Mình phải kiểm chứng, chạy hai code này:

Mã:

Sub LocMax() ' Cua Lanh
    Dim t As Double
    t = Timer
    Dim r As Long, Arr(), Dic As Object
    With ThisWorkbook.Worksheets("Sheet1")
        .Range("F1", .Cells(.Rows.Count - 1, "G").End(xlUp)).Offset(1).Clear
        Arr = .Range("B2", .Cells(.Rows.Count, "D").End(xlUp)).Value
        Set Dic = CreateObject("Scripting.Dictionary")
        For r = 1 To UBound(Arr, 1)
            If Dic.Item(Arr(r, 1)) = "" Then Dic.Item(Arr(r, 1)) = Arr(r, 3)
            If Arr(r, 3) > Dic.Item(Arr(r, 1)) Then Dic.Item(Arr(r, 1)) = Arr(r, 3)
        Next
        .Range("F2").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Keys)
        .Range("G2").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Items)
        '.Range("F2:G11").Sort Key1:=.Range("F2"), Order1:=xlAscending, Header:=xlNo
    End With
    Set Dic = Nothing
    ThisWorkbook.Worksheets("Sheet1").Range("N1000").End(xlUp).Offset(1) = Timer - t
End Sub

và

Mã:

Sub ConsolMax()    ' Cua Anh Bate
    Dim t As Double
    t = Timer
    Dim Dic As Object, Arr(), I As Long, K As Long, Tem As String
    Set Dic = CreateObject("Scripting.Dictionary")
    Arr = Range([B2], [B65000].End(xlUp)).Resize(, 3).Value
    For I = 1 To UBound(Arr, 1)
        Tem = Arr(I, 1)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, Arr(I, 3)
        Else
            If Dic.Item(Tem) < Arr(I, 3) Then Dic.Item(Tem) = Arr(I, 3)
        End If
    Next I
    With Application.WorksheetFunction
        [F2].Resize(K).Value = .Transpose(Dic.Keys)
        [G2].Resize(K).Value = .Transpose(Dic.Items)
    End With
    Set Dic = Nothing
    ThisWorkbook.Worksheets("Sheet1").Range("O1000").End(xlUp).Offset(1) = Timer - t
End Sub

Làm hai cái nút bấm và chạy em này một cái, em kia một cái (coi như công bằng về trình trạng sức khỏe của máy)

Cách 1: Không dùng .Exists và .add, có dùng Transpose
-----2: Có ------------------------ có -----------
Kết quả: Không dùng .Exists và .add thì vẫn chạy nhanh hơn từ 2-4,5% ? (hay là cách 2 có thêm công đoạn gắn vào biến Tem làm chậm hơn ?)

siwtom · 14/1/13

ndu96081631 đã viết:
Cái em quan tâm ở đây là: thằng Dictionary nó dùng thuật toán gì mà có thể Check Exists ngon lành vậy
Lúc đầu em nghĩ đến hàm StrPtr chuyển String thành Long và lấy giá trị Long này thiết lập vị trí trong mảng, đáng tiếc là thí nghiệm không thành công
Anh biết có hàm nào chuyển String thành Long không? Điều kiện là String khác nhau thì giá trị Long nhận được cũng phải khác nhau (đồng thời giá trị Long lớn nhất cũng không được lớn hơn 6 chữ số)
Nếu được như vậy thì giải pháp không còn là vấn đề

Tôi cũng chịu không biết nó làm thế nào.

Nhưng ta có thể thử cải tiến code của Hải.
Tôi nghĩ theo hướng thế này. Song song với mảng mà ta muốn thêm phần tử vào thì ta tạo ra 1 mảng cùng kích thước mà chứa chỉ số của các phần tử ở mảng "kia" nếu nó được sắp xếp tăng dần (giảm dần). Vd. ta có mảng Arr = 2, 8, 3, 1 thì ArrIndex = 4, 1, 3, 2
Ta định thêm phần tử "5" vào Arr. Để kiểm tra "5" đã tồn tại chưa thì:
Hiện thời ArrIndex có chỉ số dưới là 1, trên là 4 --> tính k = (duoi + tren) \ 2 = 2
Ta thấy Arr(ArrIndex(2)) = 2 < 5, vậy nếu 5 tồn tại thì 5 phải có chỉ số (trong Arr) nằm trong khoảng [2+1=3;4] --> tính k = (duoi + tren) \ 2 = (3 + 4) \ 2 = 3
Ta thấy Arr(ArrIndex(3)) = 3 < 5, vậy nếu 5 tồn tại thì 5 phải có chỉ số (trong Arr) nằm trong khoảng [3+1=4;4] --> tính k = (duoi + tren) \ 2 = (4 + 4) \ 2 = 4
Ta thấy Arr(ArrIndex(4)) = 8 <> 5.
Vậy 5 không tồn tại trong Arr
--------
Giả sử ta kiểm tra phần tử 1 (đã có trong Arr ở vị trí cuối cùng = 4)
k = (duoi + tren) \ 2 = 2
Ta thấy Arr(ArrIndex(2)) = 2 > 1, vậy nếu 1 tồn tại thì 1 phải có chỉ số (trong Arr) nằm trong khoảng [1, 2 - 1 = 1] --> tính k = (duoi + tren) \ 2 = (1 + 1) \ 2 = 1
Ta thấy Arr(ArrIndex(1)) = 1 => 1 tồn tại trong Arr (có chỉ số là ArrIndex(1) = 4)
-------------
Ví dụ để kiểm tra xem ô B32770 (i = 32770) có trong mảng hay không (m = 32768 = 2^15) thì chỉ cần 15 - 16 lần kiểm tra thay vì 32768 lần kiểm tra trong FOR.
---------------
Thuật toán nôm na là thế này: Để tìm một phần tử trong mảng có sắp xếp thì: Ta chia mảng thành 2 nửa bằng cách lấy phần tử "ở giữa". Nếu phần tử này "bằng" phần tử cần tìm thì ta tìm được và kết thúc. Nếu phần tử này < phần tử cần tìm thì trong bước tiếp theo ta sẽ tìm trong "nửa trên", còn nếu nó > phần tử cần tìm thì trong bước tiếp theo ta tìm trong "nửa dưới". Do "khoảng tìm kiếm" qua mỗi bước giảm đi một nửa nên ta có hữu hạn bước tìm kiếm để xác định phần tử có tồn tại hay không.

Tất nhiên đồng thời có thể trả về Index: nếu phần tử đã có trong mảng với chỉ số là n thì trả về index = n. Nếu phần tử chưa có trong mảng thì cũng xác định được n thỏa đk: phần tử thứ n của mảng < phần tử cần kiểm tra AND phần tử cần kiểm tra < phần tử (n + 1) của mảng. Lúc này vd. trả về Index = n + 1. Hàm ý là nếu thêm phần tử này vào mảng Arr (ở cuối) thì chỉ số của nó trong Arr (là m) phải ghi vào màng ArrIndex ở vị trị Index = n + 1. Tức phải mở rộng ArrIndex thêm 1 --> các phần tử từ Index dịch về cuối 1 "ô" --> ghi chỉ sổ của phần tử đã thêm, tức m, vào vị trí Index.
-------------
Tôi cũng đang nghĩ thử làm chơi một class cho việc này, dùng tree. Nếu có thời gian và hứng thì sẽ nghiên cứu.

siwtom · 14/1/13

Như đã hứa tôi viết vội một code để test cho trường hợp ~ 65000 dòng không trùng nhau từng đôi một. Như Hải nói thì code không dùng DIC mà Hải đưa ra chạy mất 180 s.

quanghai1969 đã viết:
Với cách trên thì máy tính của em cũng cho ra kết quả là 3... nhưng không phải 3s mà là 3 phút. Chính xác là 180s+
Cũng với dữ liệu này thì dùng cách .Add thì máy tính em cho ra kết quả trong 1s+
Nhưng mà anh chơi kiểu này cũng ác quá.

Tôi thử cải tiến để giảm thời gian.
Không dám nhờ Tuấn test hộ vì

Tôi chưa khi nào phải đợi code chạy quá 20s ----> Vốn nóng tính và ưa thích tốc độ nên.. Ctrl + Alt + Del cho rồi

Mà Hải lại kiên nhẫn nên nhờ Hải test hộ - vì tôi chỉ test vài lần xem code chạy có lỗi hay không mà thôi.
Hải hãy test và thông báo kết quả. Đừng sợ, tôi không "ác" như "tay" Tuấn đâu.

Có 2 ví dụ: unique lấy max (min tương tự) và unique lấy tổng.

Chuyên đề Bài tập VBA (1 người xem)

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

/(hông là gì!

Nguyễn Khắc Duy

Bad Excel Member

/(hông là gì!

Nguyễn Khắc Duy

0901452không62

Hãy cho rồi sẽ nhận!

Bùi Nguyễn Triệu Tường

Huyền thoại GPE

Bad Excel Member

Huyền thoại GPE

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

/(hông là gì!

Nguyễn Khắc Duy

Bad Excel Member

Nhi bất hoặc!

Bad Excel Member

Bad Excel Member

/(hông là gì!

Thành viên tích cực

File đính kèm

0901452không62

Huyền thoại GPE

Bad Excel Member

File đính kèm

Bad Excel Member

Thành viên tích cực

File đính kèm

Bad Excel Member

Thành viên tích cực

Huyền thoại GPE

Bad Excel Member

Bad Excel Member

Huyền thoại GPE

Hãy cho rồi sẽ nhận!

Bad Excel Member

Chuyên gia GPE

Bad Excel Member

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

File đính kèm

Huyền thoại GPE

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

Hãy cho rồi sẽ nhận!

Bad Excel Member

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

Thành viên gắn bó

Thành viên tích cực

Huyền thoại GPE

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

Huyền thoại GPE

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

Thành viên tích cực

File đính kèm

Hướng tới tương lai

Thành viên tích cực

Hướng tới tương lai

Thành viên tích cực

Cạo Rồi Khỏi Gội

Thành viên tích cực

Hướng tới tương lai

Thành viên tích cực

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

Hướng tới tương lai

Thành viên tích cực

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

Huyền thoại GPE

Hướng tới tương lai

Thành viên tích cực

Thành viên tích cực

Thành viên tích cực

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

Thành viên tích cực

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

Huyền thoại GPE

Thành viên tích cực