LỌC TRÙNG DATA BẰNG VBA

[quocthan92]

Mình có 1 vấn đề là lọc nhiều model trùng nhau thành 1 và sum số lượng, lấy ngày giờ bắt đầu đến giờ kết thúc

Rất mong được sự giúp đỡ

 

[Ba Tê]

Mình có 1 vấn đề là lọc nhiều model trùng nhau thành 1 và sum số lượng, lấy ngày giờ bắt đầu đến giờ kết thúc

Rất mong được sự giúp đỡ

Bạn chạy thử Sub này từ Module.

Public Sub GPE()
Dim sArr(), I As Long, J As Long, K As Long, R As Long, Tem As String
With Sheets("data")
    sArr = .Range("A1", .Range("A1").End(xlDown)).Resize(, 8).Value
    R = UBound(sArr): ReDim dArr(1 To R, 1 To 8)
End With
For I = 1 To R
    If sArr(I, 1) & "#" & sArr(I, 4) <> Tem Then
        K = K + 1
        Tem = sArr(I, 1) & "#" & sArr(I, 4)
        For J = 1 To 8
            dArr(K, J) = sArr(I, J)
        Next J
    Else
        dArr(K, 5) = dArr(K, 5) + sArr(I, 5)
        dArr(K, 8) = sArr(I, 8)
    End If
Next I
Sheets("result").Range("A1").Resize(K, 8) = dArr
End Sub

 

[befaint]

Mình có 1 vấn đề là lọc nhiều model trùng nhau thành 1 và sum số lượng, lấy ngày giờ bắt đầu đến giờ kết thúc

Rất mong được sự giúp đỡ

Thử tìm hiểu cái này xem...

http://www.giaiphapexcel.com/diendan/threads/tổng-quan-về-scripting-dictionary.60643/

 

[quocthan92]

Bạn chạy thử Sub này từ Module.

Public Sub GPE()
Dim sArr(), I As Long, J As Long, K As Long, R As Long, Tem As String
With Sheets("data")
    sArr = .Range("A1", .Range("A1").End(xlDown)).Resize(, 8).Value
    R = UBound(sArr): ReDim dArr(1 To R, 1 To 8)
End With
For I = 1 To R
    If sArr(I, 1) & "#" & sArr(I, 4) <> Tem Then
        K = K + 1
        Tem = sArr(I, 1) & "#" & sArr(I, 4)
        For J = 1 To 8
            dArr(K, J) = sArr(I, J)
        Next J
    Else
        dArr(K, 5) = dArr(K, 5) + sArr(I, 5)
        dArr(K, 8) = sArr(I, 8)
    End If
Next I
Sheets("result").Range("A1").Resize(K, 8) = dArr
End Sub

Anh Ba Tê đúng là thánh code, em suy nghĩ cả đêm hôm qua vẫn không ra.

 

[ndu96081631]

Mình có 1 vấn đề là lọc nhiều model trùng nhau thành 1 và sum số lượng, lấy ngày giờ bắt đầu đến giờ kết thúc

Rất mong được sự giúp đỡ

Nếu bạn định dùng bài này để tập viết code thì tôi không bàn đến
Nếu bạn định xử lý bài toán cho CÔNG VIỆC, tôi khuyên bạn dùng PivotTable, bởi nó quá đơn giản, chỉ làm 1 lần duy nhất rồi dùng mãi mãi

 

[quanluu]

Mình có 1 vấn đề là lọc nhiều model trùng nhau thành 1 và sum số lượng, lấy ngày giờ bắt đầu đến giờ kết thúc

Rất mong được sự giúp đỡ

Góp vui thêm code

Sub tong()
    Set cn = CreateObject("ADODB.Connection")
    cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";")
    Sheets("result").Range("A2").CopyFromRecordset cn.Execute("select f1, f2, f3, f4, sum(f5), f6, min(f7), max(f8) from [data$] group by f1, f2, f3, f4, f6")
End Sub

 

[quocthan92]

Bạn chạy thử Sub này từ Module.

Public Sub GPE()
Dim sArr(), I As Long, J As Long, K As Long, R As Long, Tem As String
With Sheets("data")
    sArr = .Range("A1", .Range("A1").End(xlDown)).Resize(, 8).Value
    R = UBound(sArr): ReDim dArr(1 To R, 1 To 8)
End With
For I = 1 To R
    If sArr(I, 1) & "#" & sArr(I, 4) <> Tem Then
        K = K + 1
        Tem = sArr(I, 1) & "#" & sArr(I, 4)
        For J = 1 To 8
            dArr(K, J) = sArr(I, J)
        Next J
    Else
        dArr(K, 5) = dArr(K, 5) + sArr(I, 5)
        dArr(K, 8) = sArr(I, 8)
    End If
Next I
Sheets("result").Range("A1").Resize(K, 8) = dArr
End Sub

A Ba Tê, em hỏi ngoài lề 1 tí..
1. sao em không thay With Sheet("data") .. End With bằng With Sheet2 .. End With
2. vì có 1 file excel không biết format gì mà thay đổi tên workbook thì tên sheet cũng thay đổi theo nên em không để Sheet("data") mặc định được

 

[quocthan92]

Góp vui thêm code

Sub tong()
    Set cn = CreateObject("ADODB.Connection")
    cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";")
    Sheets("result").Range("A2").CopyFromRecordset cn.Execute("select f1, f2, f3, f4, sum(f5), f6, min(f7), max(f8) from [data$] group by f1, f2, f3, f4, f6")
End Sub

Provider phải install thêm gì để debug bác