Lấy dữ liệu duy nhất trong bảng excel

giaosucan · 26/3/13

Hi các bác
em có 1 bảng excel gồm 3 cột lưu các thông tin, trong đó có nhiều thông tin trùng lặp nhau
Em muốn extract dữ liệu duy nhất trong bảng này ra 1 bảng khác mà chưa biết làm thế nào ạ
e gửi kèm file miêu tả

Thank các bác nhiều ạ

Ba Tê · 26/3/13

giaosucan đã viết:
Hi các bác
em có 1 bảng excel gồm 3 cột lưu các thông tin, trong đó có nhiều thông tin trùng lặp nhau
Em muốn extract dữ liệu duy nhất trong bảng này ra 1 bảng khác mà chưa biết làm thế nào ạ
e gửi kèm file miêu tả

Thank các bác nhiều ạ

Đang viết tiếng Việt tự nhiên extract, "bí" luôn.
"Hi các bác", "Thank các bác nhiều ạ" là tân cổ giao duyên?...
Phải vào Lạc Việt tự điển xem nó là gì... Híc! Dở ngoại ngữ cũng khổ. Thôi chạy vậy.

hoamattroicoi · 26/3/13

giaosucan đã viết:
Hi các bác
em có 1 bảng excel gồm 3 cột lưu các thông tin, trong đó có nhiều thông tin trùng lặp nhau
Em muốn extract dữ liệu duy nhất trong bảng này ra 1 bảng khác mà chưa biết làm thế nào ạ
e gửi kèm file miêu tả

Thank các bác nhiều ạ

PHP:

Sub UniqueHMT()
    Dim Dic As Object
    Dim sArr(), dArr(), kQ, tAch
    Dim i As Long, k As Long, cD, x As Long
    Set Dic = CreateObject("scripting.dictionary")
    sArr = Range([B5], [D65536].End(3)).Value
            For i = 1 To UBound(sArr, 1)
                cD = sArr(i, 1) & "#" & sArr(i, 2) & "#" & sArr(i, 3)
                If Not Dic.exists(cD) Then
                    k = k + 1
                    Dic.Add cD, ""
                    ReDim Preserve dArr(1 To 1, 1 To k)
                    dArr(1, k) = cD
                End If
            Next i
                    ReDim kQ(1 To UBound(dArr, 2), 1 To 3)
                    For i = 1 To UBound(dArr, 2)
                      tAch = Split(dArr(1, i), "#")
                            For x = 0 To 2
                                kQ(i, x + 1) = tAch(x)
                            Next x
                    Next i
     [H7:J100].ClearContents
     [H7].Resize(UBound(dArr, 2), 3) = kQ
Set Dic = Nothing
End Sub

giaosucan · 26/3/13

A dc rồi cảm ơn bác nhiều nhá

ndu96081631 · 26/3/13

hoamattroicoi đã viết:

PHP:

Sub UniqueHMT()
    Dim Dic As Object
    Dim sArr(), dArr(), kQ, tAch
    Dim i As Long, k As Long, cD, x As Long
    Set Dic = CreateObject("scripting.dictionary")
    sArr = Range([B5], [d65536].End(3)).Value
        With Dic
            For i = 1 To UBound(sArr, 1)
                cD = sArr(i, 1) & "#" & sArr(i, 2) & "#" & sArr(i, 3)
                If Not .exists(cD) Then
                    k = k + 1
                    .Add cD, ""
                    ReDim Preserve dArr(1 To 1, 1 To k)
                    dArr(1, k) = cD
                End If
            Next i
                    ReDim kQ(1 To UBound(dArr, 2), 1 To 3)
                    For i = 1 To UBound(dArr, 2)
                      tAch = Split(dArr(1, i), "#")
                            For x = 0 To 2
                                kQ(i, x + 1) = tAch(x)
                            Next x
                    Next i
                    [H7:J100].ClearContents
            [H7].Resize(UBound(dArr, 2), 3) = kQ
        End With
        Set Dic = Nothing
End Sub

Trời ơi! Hoành tráng quá! Gì mà for, next, đít to tè lè vậy
Mình chơi cái đồ cổ này thử xem:

Mã:

Sub Test()
 Sheet1.Range("B4:D1000").AdvancedFilter 2, , Sheet1.Range("H6"), True
End Sub

Crystal Rose · 26/3/13

Ba Tê đã viết:
Đang viết tiếng Việt tự nhiên extract, "bí" luôn.
"Hi các bác", "Thank các bác nhiều ạ" là tân cổ giao duyên?...
Phải vào Lạc Việt tự điển xem nó là gì... Híc! Dở ngoại ngữ cũng khổ. Thôi chạy vậy.

Thầy ơi thầy dùng thử pm dịch ngôn ngữ của thầy ndu96081631 cho nhanh ạ. %#^#$

dhn46 · 26/3/13

hoamattroicoi đã viết:

PHP:

Sub UniqueHMT()
    Dim Dic As Object
    Dim sArr(), dArr(), kQ, tAch
    Dim i As Long, k As Long, cD, x As Long
    Set Dic = CreateObject("scripting.dictionary")
    sArr = Range([B5], [d65536].End(3)).Value
        With Dic
            For i = 1 To UBound(sArr, 1)
                cD = sArr(i, 1) & "#" & sArr(i, 2) & "#" & sArr(i, 3)
                If Not .exists(cD) Then
                    k = k + 1
                    .Add cD, ""
                    ReDim Preserve dArr(1 To 1, 1 To k)
                    dArr(1, k) = cD
                End If
            Next i
                    ReDim kQ(1 To UBound(dArr, 2), 1 To 3)
                    For i = 1 To UBound(dArr, 2)
                      tAch = Split(dArr(1, i), "#")
                            For x = 0 To 2
                                kQ(i, x + 1) = tAch(x)
                            Next x
                    Next i
                    [H7:J100].ClearContents
            [H7].Resize(UBound(dArr, 2), 3) = kQ
        End With
        Set Dic = Nothing
End Sub

- HMT: Dic có thuộc tính Key sao bạn không tận dụng cái này? Code sẽ ngắn hơn, gọn hơn, nhanh hơn khi bạn khai báo ReDim Preserve dArr(1 To 1, 1 To k) đấy
- Thầy NDU: Dùng Dic cũng hay mà thầy, cái này giúp tụi VBA vỡ lòng như em tư duy hơn.

hoamattroicoi · 26/3/13

ndu96081631 đã viết:
Trời ơi! Hoành tráng quá! Gì mà for, next, đít to tè lè vậy
Mình chơi cái đồ cổ này thử xem:

Mã:

Sub Test() Sheet1.Range("B4:D1000").AdvancedFilter 2, , Sheet1.Range("H6"), True End Sub

Sư phụ ơi, em đang học code mà, sư phụ để cho em tự sướng tí, hì hì

@dhn46 : đang thử vọc thằng Preserve, hum trc có bài sort phải dùng cái này nên mình muốn ôn lại chút, lâu rồi k viết lách gì quên sạch rùi bạn ạ!

ndu96081631 · 26/3/13

hoamattroicoi đã viết:
Sư phụ ơi, em đang học code mà, sư phụ để cho em tự sướng tí, hì hì

Nếu đã "sướng" thế thì cố mà rút gọn còn 1 vòng lập thôi --> Thế càng sướng hơn!
Ẹc... Ẹc...

hoamattroicoi · 26/3/13

ndu96081631 đã viết:
Nếu đã "sướng" thế thì cố mà rút gọn còn 1 vòng lập thôi --> Thế càng sướng hơn!
Ẹc... Ẹc...

Vừa trà chanh với lũ bạn học cùng lớp về nên em bị gián đoạn câu chuyện, 1 vòng lặp thì gõ 1-2-3 hơi mỏi tay sư phụ nhỉ, thôi cho em tự sướng lần nữa sư phụ nhé :

PHP:

Sub UniqueHMT()
    Dim Dic As Object
    Dim sArr(), dArr()
    Dim i As Long, k As Long, cD, j As Long
    Set Dic = CreateObject("scripting.dictionary")
    sArr = Range([B5], [D65536].End(3)).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
            For i = 1 To UBound(sArr, 1)
                cD = sArr(i, 1) & sArr(i, 2) & sArr(i, 3)
                If Not Dic.exists(cD) Then
                    k = k + 1
                    Dic.Add cD, k
                    For j = 1 To 3
                        dArr(k, j) = sArr(i, j)
                    Next j
                End If
            Next i
        [H7:J100].ClearContents
        [H7].Resize(k, 3) = dArr
    Set Dic = Nothing
End Sub

Hai Lúa Miền Tây · 27/3/13

Cái này dùng công cụ sẵn có là Advanced Filter là "tuyệt cú mèo", nhưng lâu ngày không dùng ADO nên thấy "ngứa"

[GPECODE=sql]Sub Loc_HLMT()
Dim adoConn As Object, adoRs As Object
Set adoConn = CreateObject("ADODB.Connection")
Set adoRs = CreateObject("ADODB.Recordset")
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
.Open
End With
With adoRs
.ActiveConnection = adoConn
.Open "select distinct * from [Sheet1$B5

1000] where f1 is not null"
End With
[H7:J65000].ClearContents
[H7].CopyFromRecordset adoRs
adoRs.Close: Set adoRs = Nothing
adoConn.Close: Set adoConn = Nothing

End Sub

[/GPECODE]

Lấy dữ liệu duy nhất trong bảng excel

giaosucan

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

File đính kèm

Ba Tê

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

hoamattroicoi

Thành viên gắn bó

File đính kèm

giaosucan

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

ndu96081631

Huyền thoại GPE

Crystal Rose

Dịu dàng nhất Web

dhn46

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

hoamattroicoi

Thành viên gắn bó

ndu96081631

Huyền thoại GPE

hoamattroicoi

Thành viên gắn bó

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

File đính kèm

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

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian