Giúp đỡ lọc, ghép dữ liệu

[hpmd]

Hi mọi người,
Nhờ mọi người giúp mình lọc, ghép dữ liệu như file đính kèm:

- Thông tin đầu vào là Sheet 1, sheet 2.
- Cần tạo Sheet mới như Sheet 3, chứa thông tin tổng hợp từ Sheet 1 và Sheet 2.

Trong Sheet 3:
+ Cột A, B là những giá trị có trong cột A, B của Sheet 1.
+ Cột C,D là những giá trị có trong cột A,C của Sheet 2, mà cột B của nó trùng với Sheet 1.

Cảm ơn mọi người.

 

[HungQuoc49]

Hi mọi người,
Nhờ mọi người giúp mình lọc, ghép dữ liệu như file đính kèm:

- Thông tin đầu vào là Sheet 1, sheet 2.
- Cần tạo Sheet mới như Sheet 3, chứa thông tin tổng hợp từ Sheet 1 và Sheet 2.

Trong Sheet 3:
+ Cột A, B là những giá trị có trong cột A, B của Sheet 1.
+ Cột C,D là những giá trị có trong cột A,C của Sheet 2, mà cột B của nó trùng với Sheet 1.

Cảm ơn mọi người.

Chạy đoạn code này xem sao
Kết quả dán vào cột F để kiểm tra cho dễ

Public Sub Loc()
Dim Nguon, Tam, kq(), r As Long, c As Long, i

Nguon = Sheet2.UsedRange
ReDim kq(1 To UBound(Nguon), 1 To 4)
With CreateObject("scripting.dictionary")
For r = 2 To UBound(Nguon)
If Not .exists(Nguon(r, 2)) Then
.Add Nguon(r, 2), Array(Nguon(r, 1), Nguon(r, 3))
Else
Tam = .Item(Nguon(r, 2))
Tam(0) = Tam(0) & " " & Nguon(r, 1)
Tam(1) = Tam(1) & " " & Nguon(r, 3)
.Item(Nguon(r, 2)) = Tam
End If
Next r
Nguon = Sheet1.UsedRange

For r = 2 To UBound(Nguon)
If .exists(Nguon(r, 1)) Then
i = i + 1
kq(i, 1) = Nguon(r, 1): kq(i, 2) = Nguon(r, 2)
kq(i, 3) = Split(.Item(Nguon(r, 1))(0))(0)
kq(i, 4) = Split(.Item(Nguon(r, 1))(1))(0)
For c = 1 To UBound(Split(.Item(Nguon(r, 1))(0)))
i = i + 1
kq(i, 3) = Split(.Item(Nguon(r, 1))(0))(c)
kq(i, 4) = Split(.Item(Nguon(r, 1))(1))(c)
Next c
End If
Next r
End With

Sheet3.Range("F1:I100000").ClearContents
Sheet3.Range("F2").Resize(i, 4) = kq
Sheet3.UsedRange.Columns.AutoFit
End Sub

 

[Ba Tê]

Hi mọi người,
Nhờ mọi người giúp mình lọc, ghép dữ liệu như file đính kèm:

- Thông tin đầu vào là Sheet 1, sheet 2.
- Cần tạo Sheet mới như Sheet 3, chứa thông tin tổng hợp từ Sheet 1 và Sheet 2.

Trong Sheet 3:
+ Cột A, B là những giá trị có trong cột A, B của Sheet 1.
+ Cột C,D là những giá trị có trong cột A,C của Sheet 2, mà cột B của nó trùng với Sheet 1.

Cảm ơn mọi người.

Chạy Sub này xem kết quả có vừa ý không nhé.

Public Sub GPE()
Dim sArr(), tArr(), dArr(), I As Long, J As Long, K As Long, Tem As String
tArr = Sheet1.Range("A2", Sheet1.Range("B2").End(xlDown)).Value2
sArr = Sheet2.Range("A2", Sheet2.Range("C2").End(xlDown)).Value2
ReDim dArr(1 To UBound(sArr, 1), 1 To 4)
For I = 1 To UBound(tArr, 1)
        K = K + 1: Tem = tArr(I, 1)
        dArr(K, 1) = Tem
        dArr(K, 2) = tArr(I, 2)
        K = K - 1
    For J = 1 To UBound(sArr, 1)
        If sArr(J, 2) = Tem Then
            K = K + 1
            dArr(K, 3) = sArr(J, 1)
            dArr(K, 4) = sArr(J, 3)
        End If
    Next J
Next I
Sheet3.Range("A2").Resize(K, 4) = dArr
End Sub

 

[Avenged7]

Cảm ơn 2 bác rất nhiều. Nếu giờ mình muốn chèn thêm một số cột ở giữa nữa, lấy từ Sheet 1 thì chỉnh lại thế nào nhỉ?

 

[Ba Tê]

Cảm ơn 2 bác rất nhiều. Nếu giờ mình muốn chèn thêm một số cột ở giữa nữa, lấy từ Sheet 1 thì chỉnh lại thế nào nhỉ?

Sao người này hỏi mà người khác "nếu".
Nếu bạn "đọc" được code thì sẽ thấy mấy chỗ cần thay đổi theo dữ liệu mới.

Public Sub GPE()
Dim sArr(), tArr(), dArr(), I As Long, J As Long, K As Long, Tem As String
tArr = Sheet1.Range("A2", Sheet1.Range("F2").End(xlDown)).Value2
sArr = Sheet2.Range("A2", Sheet2.Range("C2").End(xlDown)).Value2
ReDim dArr(1 To UBound(sArr, 1), 1 To 8)
For I = 1 To UBound(tArr, 1)
        K = K + 1: Tem = tArr(I, 1)
        For J = 1 To 6
            dArr(K, J) = tArr(I, J)
        Next J
        K = K - 1
    For J = 1 To UBound(sArr, 1)
        If sArr(J, 2) = Tem Then
            K = K + 1
            dArr(K, 7) = sArr(J, 1)
            dArr(K, 8) = sArr(J, 3)
        End If
    Next J
Next I
Sheet3.Range("A2").Resize(K, 8) = dArr
End Sub

 

[Avenged7]

OK, thank bác...

 

[Avenged7]

Hic phiền bác thêm xíu nữa. Giúp mình thêm nếu cột F là "NO" thì khỏi trích dữ liệu từ Sheet 2 ra, nếu "YES" thì lấy (Nếu "NO" thì cột G,H để trống)

 

[huuphuoc1204]

Xóa dữ liệu trùng

Xin chào các anh/chị trên diễn đàn. Em có một vấn đề nhờ anh chị giúp đỡ: Từ hệ thống chấm công

[COLOR=#0000FF ! important]download[/COLOR]​

về số giờ bấm thẻ. Một người bấm thẻ 4 lần một ngày (trừ những người tăng ca), vấn đề là máy chấm công lặp lại mốc giờ quá nhiều. ví dụ: Nguyễn Văn A buổi sáng bấm thẻ 7:04 nó lặp lại 3->4 lần, mốc t.gian trưa, chiều cũng thế. Em muốn xóa dữ

[COLOR=#0000FF ! important]liệu trùng[/COLOR]​

trên cùng một dòng chỉ để lại mỗi mốc thời gian hiển hiện một lần. có cách nào nhờ anh chị chỉ dẫn giùm. cám ơn!(Em có kèm file bên dưới)

 

[Avenged7]

Chắc Bác ấy ngủ rồi! TÔi sửa giúpbạn vậy

Public Sub GPE()
Dim sArr(), tArr(), dArr(), I As Long, J As Long, K As Long, Tem As String
tArr = Sheet1.Range("A2", Sheet1.Range("F2").End(xlDown)).Value2
sArr = Sheet2.Range("A2", Sheet2.Range("C2").End(xlDown)).Value2
ReDim dArr(1 To UBound(sArr, 1), 1 To 8)
For I = 1 To UBound(tArr, 1)
    'If tArr(I, 6) = "NO" Then
        K = K + 1: Tem = tArr(I, 1)
        For J = 1 To 6
            dArr(K, J) = tArr(I, J)
        Next J
        K = K - 1
    For J = 1 To UBound(sArr, 1)
        If sArr(J, 2) = Tem Then
            K = K + 1
        If tArr(I, 6) = "YES" Then
            dArr(K, 7) = sArr(J, 1)
            dArr(K, 8) = sArr(J, 3)
        End If
        End If
    Next J
    'End If
Next I
Sheet3.Range("A2").Resize(K, 8) = dArr
End Sub

Cho mấy hàng có "NO" gần sát lại chứ không cách ra được không bác?

 

[Ba Tê]

Hic phiền bác thêm xíu nữa. Giúp mình thêm nếu cột F là "NO" thì khỏi trích dữ liệu từ Sheet 2 ra, nếu "YES" thì lấy (Nếu "NO" thì cột G,H để trống)

Muốn làm gì thì "tưởng tượng" sẵn kết quả muốn có rồi nhờ người giúp 1 lần cho xong.
"Nếu" với bạn lần cuối nhé.

Public Sub GPE()
Dim sArr(), tArr(), dArr(), I As Long, J As Long, K As Long, Tem As String, DK As String
tArr = Sheet1.Range("A2", Sheet1.Range("F2").End(xlDown)).Value2
sArr = Sheet2.Range("A2", Sheet2.Range("C2").End(xlDown)).Value2
ReDim dArr(1 To UBound(sArr, 1), 1 To 8)
For I = 1 To UBound(tArr, 1)
        K = K + 1: Tem = tArr(I, 1): DK = tArr(I, 6)
        For J = 1 To 6
            dArr(K, J) = tArr(I, J)
        Next J
    If DK <> "NO" Then
        K = K - 1
        For J = 1 To UBound(sArr, 1)
            If sArr(J, 2) = Tem Then
                K = K + 1
                dArr(K, 7) = sArr(J, 1)
                dArr(K, 8) = sArr(J, 3)
            End If
        Next J
    End If
Next I
Sheet3.Range("A2:H1000").ClearContents
Sheet3.Range("A2").Resize(K, 8) = dArr
End Sub

 

[hongden18]

Chạy đoạn code này xem sao
Kết quả dán vào cột F để kiểm tra cho dễ

Public Sub Loc()
Dim Nguon, Tam, kq(), r As Long, c As Long, i

Nguon = Sheet2.UsedRange
ReDim kq(1 To UBound(Nguon), 1 To 4)
With CreateObject("scripting.dictionary")
For r = 2 To UBound(Nguon)
If Not .exists(Nguon(r, 2)) Then
.Add Nguon(r, 2), Array(Nguon(r, 1), Nguon(r, 3))
Else
Tam = .Item(Nguon(r, 2))
Tam(0) = Tam(0) & " " & Nguon(r, 1)
Tam(1) = Tam(1) & " " & Nguon(r, 3)
.Item(Nguon(r, 2)) = Tam
End If
Next r
Nguon = Sheet1.UsedRange

For r = 2 To UBound(Nguon)
If .exists(Nguon(r, 1)) Then
i = i + 1
kq(i, 1) = Nguon(r, 1): kq(i, 2) = Nguon(r, 2)
kq(i, 3) = Split(.Item(Nguon(r, 1))(0))(0)
kq(i, 4) = Split(.Item(Nguon(r, 1))(1))(0)
For c = 1 To UBound(Split(.Item(Nguon(r, 1))(0)))
i = i + 1
kq(i, 3) = Split(.Item(Nguon(r, 1))(0))(c)
kq(i, 4) = Split(.Item(Nguon(r, 1))(1))(c)
Next c
End If
Next r
End With

Sheet3.Range("F1:I100000").ClearContents
Sheet3.Range("F2").Resize(i, 4) = kq
Sheet3.UsedRange.Columns.AutoFit
End Sub

Hướng dẫn mình chạy cái này được không nhỉ