Giúp đỡ trích xuất dữ liệu có điều kiện (1 người xem)

Elx Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
A

Avenged7

Thành viên mới
Tham gia
2/1/15
Bài viết
24
Được thích
0
Mấy bác giúp đỡ em xử lý file excel này với ạ. %#^#$
Em cần list ra danh sách các "GroupPoints" trong "Sheet 2" đưa vào "Sheet 1" theo dạng cách nhau theo dấu "," như file đính kèm. Điều kiện là giá trị "GroupPoints" đó xuất hiện từ 2 lần trở lên trong cột "GroupPoints" của "Sheet 2". Giá trị xuất theo từng "POP" đưa vào "Sheet 1"
Đa tạ mọi người /-*+/
 

File đính kèm

Avenged7 đã viết:
Mấy bác giúp đỡ em xử lý file excel này với ạ. %#^#$
Em cần list ra danh sách các "GroupPoints" trong "Sheet 2" đưa vào "Sheet 1" theo dạng cách nhau theo dấu "," như file đính kèm. Điều kiện là giá trị "GroupPoints" đó xuất hiện từ 2 lần trở lên trong cột "GroupPoints" của "Sheet 2". Giá trị xuất theo từng "POP" đưa vào "Sheet 1"
Đa tạ mọi người /-*+/
Nhấp chuột vào đây để mở rộng...

Chạy thử Sub này rồi tuỳ nghi chế biến.
(Đọc không hiểu)
PHP: 
Public Sub GPE()
Dim Dic As Object, sArr(), dArr(), I As Long, K As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet2
    sArr = .Range(.[A2], .[B2].End(xlDown)).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
For I = 1 To UBound(sArr, 1)
    If Not Dic.Exists(sArr(I, 1)) Then
        K = K + 1
        Dic.Add sArr(I, 1), K
        dArr(K, 1) = sArr(I, 1)
        dArr(K, 2) = 1
        dArr(K, 3) = sArr(I, 2)
    Else
        Rws = Dic.Item(sArr(I, 1))
        dArr(Rws, 2) = dArr(Rws, 2) + 1
        dArr(Rws, 3) = dArr(Rws, 3) & "," & sArr(I, 2)
    End If
Next I
With Sheet1
    .[A2].Resize(K, 3) = dArr
    .Range("A2").Resize(K, 3).Sort Key1:=.Range("B2"), Order1:=xlDescending
End With
Set Dic = Nothing
End Sub
-----------------------
Thấy cách làm của hoamattroicoi ở bài dưới (#3), hình như mình hiểu sai vấn đề, làm lại trong file này vậy.
 

File đính kèm

Lần chỉnh sửa cuối:
Avenged7 đã viết:
Mấy bác giúp đỡ em xử lý file excel này với ạ. %#^#$
Em cần list ra danh sách các "GroupPoints" trong "Sheet 2" đưa vào "Sheet 1" theo dạng cách nhau theo dấu "," như file đính kèm. Điều kiện là giá trị "GroupPoints" đó xuất hiện từ 2 lần trở lên trong cột "GroupPoints" của "Sheet 2". Giá trị xuất theo từng "POP" đưa vào "Sheet 1"
Đa tạ mọi người /-*+/
Nhấp chuột vào đây để mở rộng...

Bạn sử dụng hàm này xem sao :
Mã: 
Function Timdulieu(POP As Range, Group As Range)
Dim i As Long, sArr(), dArr, k As Long
Dim Tmp, kQ
Dim Dic As Object
Set Dic = CreateObject("Scripting.dictionary")
sArr = POP.Value
ReDim dArr(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
If sArr(i, 1) = Group.Value Then
    If Not Dic.exists(sArr(i, 2)) Then
        k = k + 1
        Dic.Add sArr(i, 2), k
        dArr(k, 1) = 1
    Else
    dArr(Dic.Item(sArr(i, 2)), 1) = dArr(Dic.Item(sArr(i, 2)), 1) + 1
    End If
End If
Next
Tmp = Dic.Keys
For i = 0 To Dic.Count - 1
    If dArr(i + 1, 1) > 1 Then
      kQ = Tmp(i) & ", " & kQ
    End If
Next
    If Len(kQ) > 0 Then
        Timdulieu = Left(kQ, Len(kQ) - 2)
    Else
        Timdulieu = ""
    End If
Set Dic = Nothing
End Function

Bạn copy code kia vào module sau đó trong ô B2 trong sheet1 bạn gõ công thức sau :
=Timdulieu(Sheet2!$A$2:$B$324,Sheet1!A2)
=> Copy xuống cho những ô còn lại.
 
Avenged7 đã viết:
Mấy bác giúp đỡ em xử lý file excel này với ạ. %#^#$
Em cần list ra danh sách các "GroupPoints" trong "Sheet 2" đưa vào "Sheet 1" theo dạng cách nhau theo dấu "," như file đính kèm. Điều kiện là giá trị "GroupPoints" đó xuất hiện từ 2 lần trở lên trong cột "GroupPoints" của "Sheet 2". Giá trị xuất theo từng "POP" đưa vào "Sheet 1"
Đa tạ mọi người /-*+/
Nhấp chuột vào đây để mở rộng...

trong sheet2 chèn thêm cột E
Mã: 
E2=IF(COUNTIFS($A$1:A1,A2,$B$1:B1,B2)=1,  IFERROR( LOOKUP(2,1/($A$1:A1=A2)/($E$1:E1<>""),$E$1:E1)&", "&B2,B2),"")

quay về sheet1
Mã: 
B2=IFERROR( LOOKUP(2,1/(Sheet2!$A$2:$A$900=A2)/(Sheet2!$E$2:$E$900<>""),Sheet2!$E$2:$E$900),"")
 
Lần chỉnh sửa cuối:
hoamattroicoi đã viết:
Bạn sử dụng hàm này xem sao :
Mã: 
Function Timdulieu(POP As Range, Group As Range)
Dim i As Long, sArr(), dArr, k As Long
Dim Tmp, kQ
Dim Dic As Object
Set Dic = CreateObject("Scripting.dictionary")
sArr = POP.Value
ReDim dArr(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
If sArr(i, 1) = Group.Value Then
    If Not Dic.exists(sArr(i, 2)) Then
        k = k + 1
        Dic.Add sArr(i, 2), k
        dArr(k, 1) = 1
    Else
    dArr(Dic.Item(sArr(i, 2)), 1) = dArr(Dic.Item(sArr(i, 2)), 1) + 1
    End If
End If
Next
Tmp = Dic.Keys
For i = 0 To Dic.Count - 1
    If dArr(i + 1, 1) > 1 Then
      kQ = Tmp(i) & ", " & kQ
    End If
Next
    If Len(kQ) > 0 Then
        Timdulieu = Left(kQ, Len(kQ) - 2)
    Else
        Timdulieu = ""
    End If
Set Dic = Nothing
End Function

Bạn copy code kia vào module sau đó trong ô B2 trong sheet1 bạn gõ công thức sau :
=Timdulieu(Sheet2!$A$2:$B$324,Sheet1!A2)
=> Copy xuống cho những ô còn lại.
Nhấp chuột vào đây để mở rộng...

dù là Sub hay Function thì cũng chỉ có 1 vòng lặp thui , có giao lưu không ? hi hi
 
doveandrose đã viết:
dù là Sub hay Function thì cũng chỉ có 1 vòng lặp thui , có giao lưu không ? hi hi
Nhấp chuột vào đây để mở rộng...

Ngưởi đẹp doveandrose quyến rũ, hihihi

Mã: 
Function Timdulieu(POP As Range, Group As Range)Dim i As Long, sArr(), dArr, k As Long, Tmp, kQ
Dim Dic As Object, Dic2 As Object
Set Dic1 = CreateObject("Scripting.dictionary")
Set Dic2 = CreateObject("Scripting.dictionary")
sArr = POP.Value
ReDim dArr(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
If sArr(i, 1) = Group.Value Then
    If Not Dic1.exists(sArr(i, 2)) Then
        k = k + 1
        Dic1.Add sArr(i, 2), k
        dArr(k, 1) = 1
    Else
    dArr(Dic1.Item(sArr(i, 2)), 1) = dArr(Dic1.Item(sArr(i, 2)), 1) + 1
        If dArr(Dic1.Item(sArr(i, 2)), 1) > 1 Then
            If Not Dic2.exists(sArr(i, 2)) Then
                Dic2(sArr(i, 2)) = ""
                kQ = sArr(i, 2) & ", " & kQ
            End If
        End If
    End If
End If
Next
If Len(kQ) > 0 Then
Timdulieu = Left(kQ, Len(kQ) - 2)
Else
Timdulieu = ""
End If
Set Dic1 = Nothing
Set Dic2 = Nothing
End Function
 
hoamattroicoi đã viết:
Ngưởi đẹp doveandrose quyến rũ, hihihi

Mã: 
Function Timdulieu(POP As Range, Group As Range)Dim i As Long, sArr(), dArr, k As Long, Tmp, kQ
Dim Dic As Object, Dic2 As Object
Set Dic1 = CreateObject("Scripting.dictionary")
Set Dic2 = CreateObject("Scripting.dictionary")
sArr = POP.Value
ReDim dArr(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
If sArr(i, 1) = Group.Value Then
    If Not Dic1.exists(sArr(i, 2)) Then
        k = k + 1
        Dic1.Add sArr(i, 2), k
        dArr(k, 1) = 1
    Else
    dArr(Dic1.Item(sArr(i, 2)), 1) = dArr(Dic1.Item(sArr(i, 2)), 1) + 1
        If dArr(Dic1.Item(sArr(i, 2)), 1) > 1 Then
            If Not Dic2.exists(sArr(i, 2)) Then
                Dic2(sArr(i, 2)) = ""
                kQ = sArr(i, 2) & ", " & kQ
            End If
        End If
    End If
End If
Next
If Len(kQ) > 0 Then
Timdulieu = Left(kQ, Len(kQ) - 2)
Else
Timdulieu = ""
End If
Set Dic1 = Nothing
Set Dic2 = Nothing
End Function
Nhấp chuột vào đây để mở rộng...

giờ thí dụ như chỉ cho phép 1 Dic và không cần dArr thì sao ta ? hi hi
 
- 12 dòng code thì giống kiểu cưỡng hôn quá người đẹp ợ, nhưng bạn đẹp bạn có quyền :D....18 dòng code của mình vượt budget rùi, mình chờ 12 dòng code của người đẹp }}}}}

Mã: 
Function Timdulieu(POP As Range, Group As Range)
Dim i As Long, sArr(), k As Long, kQ, Dic As Object
Set Dic = CreateObject("Scripting.dictionary")
sArr = POP.Value
For i = 1 To UBound(sArr)
If sArr(i, 1) = Group.Value Then
    If Not Dic.exists(sArr(i, 2)) Then
         k = k + 1
         Dic.Add sArr(i, 2), Array(k, 1)
    Else
            Dic.Item(sArr(i, 2)) = Array(Dic.Item(sArr(i, 2))(0), Dic.Item(sArr(i, 2))(1) + 1)
            If Dic.Item(sArr(i, 2))(1) = 2 Then kQ = sArr(i, 2) & ", " & kQ
    End If
End If
Next
If Len(kQ) > 0 Then Timdulieu = Left(kQ, Len(kQ) - 2)
Set Dic = Nothing
End Function
 
Lần chỉnh sửa cuối:
hoamattroicoi đã viết:
- 12 dòng code thì giống kiểu cưỡng hôn quá người đẹp ợ....18 dòng code của mình vượt budget rùi, mình chờ 12 dòng code của người đẹp }}}}}

Mã: 
Function Timdulieu(POP As Range, Group As Range)
Dim i As Long, sArr(), k As Long, kQ, Dic As Object
Set Dic = CreateObject("Scripting.dictionary")
sArr = POP.Value
For i = 1 To UBound(sArr)
If sArr(i, 1) = Group.Value Then
    If Not Dic.exists(sArr(i, 2)) Then
         k = k + 1
         Dic.Add sArr(i, 2), Array(k, 1)
    Else
            Dic.Item(sArr(i, 2)) = Array(Dic.Item(sArr(i, 2))(0), Dic.Item(sArr(i, 2))(1) + 1)
            If Dic.Item(sArr(i, 2))(1) = 2 Then kQ = sArr(i, 2) & ", " & kQ
    End If
End If
Next
If Len(kQ) > 0 Then Timdulieu = Left(kQ, Len(kQ) - 2)
Set Dic = Nothing
End Function
Nhấp chuột vào đây để mở rộng...

ồ có vẻ Hoamattroicoi đã nhìn thấy bản chất công thức của #4 rùi . hi hi
doveandrose thật áy náy vì báo hại Hoamattroicoi không được ngủ sớm .
doveandrose không dám múa rìu qua mắt ních xanh đâu , nhưng vì được mời nên cố gắng làm thử vậy
Mã: 
Public Function HoamattroiDeThuong(POP As Range, Group As Range) As String
Dim Dic As Object, arr, dk, st As String, r As Long
Set Dic = CreateObject("Scripting.dictionary")
arr = POP.Value: dk = Group.Value
For r = 1 To UBound(arr) Step 1
    If arr(r, 1) = dk Then
        Dic(arr(r, 2)) = Dic(arr(r, 2)) + 1
        If Dic(arr(r, 2)) = 2 Then st = st & ", " & arr(r, 2)
    End If
Next
HoamattroiDeThuong = Mid(st, 3)
End Function
 
Người ta bảo ép dầu, ép mỡ chứ ai nỡ ép code. Sáng nay định ép nốt code nhưng người đẹp dậy sớm đã tiếp sức nhanh quá.

Ngày xưa thầy mình dạy không nên tư duy code theo công thức.
 
hoamattroicoi đã viết:
Người ta bảo ép dầu, ép mỡ chứ ai nỡ ép code. Sáng nay định ép nốt code nhưng người đẹp dậy sớm đã tiếp sức nhanh quá.

Ngày xưa thầy mình dạy không nên tư duy code theo công thức.
Nhấp chuột vào đây để mở rộng...
1) Vậy "bi giờ" ép tiếp đi, với dữ liệu như trong bài, đừng xài "đít to đít bé" gì nữa, vẫn một vòng lặp đi với....2 thằng If
2) Nếu dùng Sub lấy kết quả cho 10 em ở cột A sheet1 cùng lúc có thể sử dụng bộ lọc cho vòng lặp chạy ít thôi
Mới nghĩ ra thế, "hông" biết đúng "hông" nữa, bé Còi đừng bắt bác Cò làm nhé. Thân
Híc
 
Lần chỉnh sửa cuối:
OK rồi. Đa tạ mấy bác :D

Giờ em cần thêm 2 yêu cầu này nữa ạ, mấy bác giúp em nốt phát

1. Chuyển cột 3 trong sheet 1 từ dạng "cách nhau dấu phẩy" sang dạng từng thành phần trên mỗi cell (như sheet 2). (Nghĩa là làm ngược lại ấy ạ).

2. Lọc từ cột 3, các "thành phần chỉ có một dấu chấm", mà xuất hiện từ 2 lần trở lên, đưa vào cột 2 (như sheet 1)
Ví dụ : Cột 3 có: NTGP006.10.0066, NTGP006.10.0065, NTGP006.10.0070... thì lấy NTGP006.10 đưa vào cột 2.

Giải thích hơi loằng ngoằng, hi vọng mọi người hiểu... !$@!!
 

File đính kèm

concogia đã viết:
1) Vậy "bi giờ" ép tiếp đi, với dữ liệu như trong bài, đừng xài "đít to đít bé" gì nữa, vẫn một vòng lặp đi với....2 thằng If
Nhấp chuột vào đây để mở rộng...
2 IF khó nuốt quá bác Cò ơi, bé còi 3 IF nha bác Cò, hihihi
Mã: 
Function Timdulieu(POP As Range, Group As Range)
Dim i As Long, sArr(), kQ, onPOP As String
sArr = POP.Value
For i = 1 To UBound(sArr)
If sArr(i, 1) = Group.Value Then
    If InStr(1, onPOP, sArr(i, 2)) = 0 Then
            onPOP = onPOP & sArr(i, 2)
    Else
            If InStr(1, kQ, sArr(i, 2)) = 0 Then kQ = kQ & ", " & sArr(i, 2)
    End If
End If
Next
Timdulieu = Mid(kQ, 3)
End Function
 
hoamattroicoi đã viết:
2 IF khó nuốt quá bác Cò ơi, bé còi 3 IF nha bác Cò, hihihi
Mã: 
Function Timdulieu(POP As Range, Group As Range)
Dim i As Long, sArr(), kQ, onPOP As String
sArr = POP.Value
For i = 1 To UBound(sArr)
If sArr(i, 1) = Group.Value Then
    If InStr(1, onPOP, sArr(i, 2)) = 0 Then
            onPOP = onPOP & sArr(i, 2)
    Else
            If InStr(1, kQ, sArr(i, 2)) = 0 Then kQ = kQ & ", " & sArr(i, 2)
    End If
End If
Next
Timdulieu = Mid(kQ, 3)
End Function
Nhấp chuột vào đây để mở rộng...
Híc, cái này tính 2 If là ok rồi, nhìn thấy gọn quá xá cỡ, bé Còi ....giỏi quá
 
Avenged7 đã viết:
OK rồi. Đa tạ mấy bác :D

Giờ em cần thêm 2 yêu cầu này nữa ạ, mấy bác giúp em nốt phát

1. Chuyển cột 3 trong sheet 1 từ dạng "cách nhau dấu phẩy" sang dạng từng thành phần trên mỗi cell (như sheet 2). (Nghĩa là làm ngược lại ấy ạ).

2. Lọc từ cột 3, các "thành phần chỉ có một dấu chấm", mà xuất hiện từ 2 lần trở lên, đưa vào cột 2 (như sheet 1)
Ví dụ : Cột 3 có: NTGP006.10.0066, NTGP006.10.0065, NTGP006.10.0070... thì lấy NTGP006.10 đưa vào cột 2.

Giải thích hơi loằng ngoằng, hi vọng mọi người hiểu... !$@!!
Nhấp chuột vào đây để mở rộng...

Tiếp chiêu số 1 nhé, số 2 loằng ngoằng khó hiểu quá.
Không chơi với Merge Cells nhé, nếu muốn thì bạn làm thủ công.
PHP: 
Public Sub GPE_1()
Dim sArr(), dArr(1 To 1000000, 1 To 2), I As Long, J As Long, K As Long, Tem
sArr = Sheet1.Range(Sheet1.[A2], Sheet1.[C2].End(xlDown)).Value
For I = 1 To UBound(sArr, 1)
    K = K + 1:          dArr(K, 1) = sArr(I, 1):        K = K - 1
    Tem = Split(sArr(I, 3), ", ")
    For J = 0 To UBound(Tem)
        K = K + 1:      dArr(K, 2) = Tem(J)
    Next J
Next I
Sheet2.[A2:B2].Resize(K) = dArr
End Sub
 
Lần chỉnh sửa cuối:
Ba Tê đã viết:
Tiếp chiêu số 1 nhé, số 2 loằng ngoằng khó hiểu quá.
Không chơi với Merge Cells nhé, nếu muốn thì bạn làm thủ công.
PHP: 
Public Sub GPE_1()
Dim sArr(), dArr(1 To 1000000, 1 To 2), I As Long, J As Long, K As Long, Tem
sArr = Sheet1.Range(Sheet1.[A2], Sheet1.[C2].End(xlDown)).Value
For I = 1 To UBound(sArr, 1)
    K = K + 1:          dArr(K, 1) = sArr(I, 1):        K = K - 1
    Tem = Split(sArr(I, 3), ", ")
    For J = 0 To UBound(Tem)
        K = K + 1:      dArr(K, 2) = Tem(J)
    Next J
Next I
Sheet2.[A2:B2].Resize(K) = dArr
End Sub
Nhấp chuột vào đây để mở rộng...

Làm sao để dùng code này vậy bác, em gà mờ vụ này :.,
Bác nào giúp em cái 2 với ạ **~**
 
Ba Tê đã viết:
Khi mở file, chọn Enable Macros, bấm nút ở sheet2
Alt+F11 thấy Code
Nhấp chuột vào đây để mở rộng...

Được rồi bác %#^#$
Bác giúp em nốt cái 2 với ạ. Cái này nghĩa là trích những thằng nào dạng "NTGP0xx.xx" xuất hiện từ 2 lần trờ lên đưa vào cột 2 trong "Sheet 1".

Cảm ơn bác nhiều @$@!^%
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
9
Đọc
316
vinh91@
V
thanhss
Nhờ tìm công thức tính tổng theo hàng có kèm dữ liệu Text
Trả lời
6
Đọc
79
thanhss
thanhss
befaint
Chia sẻ tâm tư, xả nỗi lòng (3 người xem)
    • Thích
6 7 8
Trả lời
777
Đọc
72K
befaint
befaint
H
  • Question Question
Code Sổ Chi Tiết Tài Khoản (2 người xem)
Trả lời
4
Đọc
153
hieuvietmy2020
H
H
File excel bị lỗi không mở được
Trả lời
6
Đọc
57
hiep204
H
Nguyễn Duy Tuân
[New] BSAC v3.0 bộ công cụ lập trình phần mềm chuyên nghiệp trong VBA
    • Thích
Trả lời
10
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
A
  • Question Question
Sửa code VBA nhập liệu userform
Trả lời
24
Đọc
990
ongke0711
ongke0711
SA_DQ
Copilot & bài thơ chia bánh do 'Hắn' sáng tác
Trả lời
2
Đọc
66
SA_DQ
SA_DQ
HeSanbi
  • Đã giải quyết
WeatherXL - Ứng dụng lấy dữ liệu Thời tiết siêu nhanh (***Nguồn cấp FreeMeteo đã dừng cấp dữ liệu lịch sử) (1 người xem)
    • Thích
    • Yêu thích
Trả lời
90
Đọc
25K
dinhhoangcd13
D
T
GẤP: TÌM GIÁ THEO TỪNG KHÁCH
Trả lời
7
Đọc
344
tulipviet
T
D
lấy thẻ kho từ sổ kho nên dùng hàm nào ah
Trả lời
3
Đọc
88
dankedun
D
L
công thứ tìm giá trị giao hàng với cột
Trả lời
13
Đọc
204
luongcongdua
L
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (7 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
552
Đọc
70K
ongke0711
ongke0711
K
Nhờ anh chị làm công thức lọc dữ kiện ngày từ bảng 1 sang rút gọn ngày ở bảng 2.
Trả lời
1
Đọc
112
thanthanhan
thanthanhan
SA_DQ
Tìm số chính phương trong 1 biểu thức cho trước
    • Thích
    • Yêu thích
Trả lời
22
Đọc
399
dungpham01
D
T
TỈNH TỔNG TỪNG Ô THEO ĐIỀU KIỆN
Trả lời
3
Đọc
134
thanthanhan
thanthanhan
8
Tính tổng điểm 3 môn theo tổ hợp xét tuyển
Trả lời
3
Đọc
106
ptm0412
ptm0412
N
  • Question Question
Tool chia băng kết hợp bên ngành tôn
Trả lời
0
Đọc
102
nguyenanhtruong2409
N
S
Chỉnh công thức tính tỷ lệ hoàn thành giúp mình với.
Trả lời
8
Đọc
484
ptm0412
ptm0412
L
Tìm giải pháp trừ lùi nguyên liệu xuất nhập khẩu
Trả lời
9
Đọc
318
luongcongdua
L
Xem thêm…

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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom