Nhờ giúp đỡ code tạo danh sách mới từ một danh sách ban đầu và danh sách điều kiện

Shaa · 29/8/24

Chào anh/chị!
Em đang có một bài toán cần nhờ a chị giúp đỡ
Em muôn tạo một danh sách mới từ danh sách ban đầu nhưng lại dựa vào các điều kiện từ danh sách khác
Cụ thể em để như tệp đính kèm ạ
Các anh/chị xem và giúp đỡ em với nhé
Em cảm ơn ạ!

hoangtuaotrang_hp_vn · 30/8/24

Shaa đã viết:
Chào anh/chị!
Em đang có một bài toán cần nhờ a chị giúp đỡ
Em muôn tạo một danh sách mới từ danh sách ban đầu nhưng lại dựa vào các điều kiện từ danh sách khác
Cụ thể em để như tệp đính kèm ạ
Các anh/chị xem và giúp đỡ em với nhé
Em cảm ơn ạ!

up tạm file dùng công thức, (mục đích chống trôi bài), vì mình phải sử dụng nhiều cột phụ quá, e là không tối ưu

CHAOQUAY · 30/8/24

Shaa đã viết:
Chào anh/chị!
Em đang có một bài toán cần nhờ a chị giúp đỡ
Em muôn tạo một danh sách mới từ danh sách ban đầu nhưng lại dựa vào các điều kiện từ danh sách khác
Cụ thể em để như tệp đính kèm ạ
Các anh/chị xem và giúp đỡ em với nhé
Em cảm ơn ạ!

Thử code dưới xem sao

Mã:

Option Explicit

Sub zzz()
Dim DS1
Dim DS3
Dim DS2
Dim i, j, k

With Sheet1
    DS1 = .Range("A4", .Range("A4").End(xlDown))
    DS3 = .Range("G4", .Range("H4").End(xlDown))
End With
ReDim DS2(1 To UBound(DS1), 1 To 1)

With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(DS3)
        If .exists(DS3(i, 1)) = False And .exists(DS3(i, 2)) = False Then
            k = k + 1
            .Item(DS3(i, 1)) = k
            .Item(DS3(i, 2)) = k
            DS2(k, 1) = DS3(i, 1) & "/" & DS3(i, 2)
        Else
            If .exists(DS3(i, 1)) = False Then
                k = .Item(DS3(i, 2))
                .Item(DS3(i, 1)) = k
                DS2(k, 1) = DS2(k, 1) & "/" & DS3(i, 1)
            Else
                If .exists(DS3(i, 2)) = False Then
                    k = .Item(DS3(i, 1))
                    .Item(DS3(i, 2)) = k
                    DS2(k, 1) = DS2(k, 1) & "/" & DS3(i, 2)
                End If
            End If
        End If
    Next i
    
    For i = 1 To UBound(DS1)
        If .exists(DS1(i, 1)) Then DS1(i, 1) = ""
    Next i
End With

If k < UBound(DS2) Then
    For i = 1 To UBound(DS1)
        If DS1(i, 1) <> "" Then
            k = k + 1
            DS2(k, 1) = DS1(i, 1)
        End If
    Next i
End If

With Sheet1
    .Range("K4").Resize(UBound(DS2), 1).ClearContents
    .Range("K4").Resize(UBound(DS2), 1) = DS2
    .Range("K4").Resize(UBound(DS2), 1).Columns.AutoFit
End With
End Sub

Shaa · 30/8/24

hoangtuaotrang_hp_vn đã viết:
up tạm file dùng công thức, (mục đích chống trôi bài), vì mình phải sử dụng nhiều cột phụ quá, e là không tối ưu

Em cảm ơn bác ạ
nhưng mấy công thức của bác lạ quá, em chưa học được. em dùng bản Excel 2016 hình như cũng không có bác ạ

Bài đã được tự động gộp: 30/8/24

CHAOQUAY đã viết:

Thử code dưới xem sao

Mã:

Option Explicit

Sub zzz()
Dim DS1
Dim DS3
Dim DS2
Dim i, j, k

With Sheet1
    DS1 = .Range("A4", .Range("A4").End(xlDown))
    DS3 = .Range("G4", .Range("H4").End(xlDown))
End With
ReDim DS2(1 To UBound(DS1), 1 To 1)

With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(DS3)
        If .exists(DS3(i, 1)) = False And .exists(DS3(i, 2)) = False Then
            k = k + 1
            .Item(DS3(i, 1)) = k
            .Item(DS3(i, 2)) = k
            DS2(k, 1) = DS3(i, 1) & "/" & DS3(i, 2)
        Else
            If .exists(DS3(i, 1)) = False Then
                k = .Item(DS3(i, 2))
                .Item(DS3(i, 1)) = k
                DS2(k, 1) = DS2(k, 1) & "/" & DS3(i, 1)
            Else
                If .exists(DS3(i, 2)) = False Then
                    k = .Item(DS3(i, 1))
                    .Item(DS3(i, 2)) = k
                    DS2(k, 1) = DS2(k, 1) & "/" & DS3(i, 2)
                End If
            End If
        End If
    Next i
   
    For i = 1 To UBound(DS1)
        If .exists(DS1(i, 1)) Then DS1(i, 1) = ""
    Next i
End With

If k < UBound(DS2) Then
    For i = 1 To UBound(DS1)
        If DS1(i, 1) <> "" Then
            k = k + 1
            DS2(k, 1) = DS1(i, 1)
        End If
    Next i
End If

With Sheet1
    .Range("K4").Resize(UBound(DS2), 1).ClearContents
    .Range("K4").Resize(UBound(DS2), 1) = DS2
    .Range("K4").Resize(UBound(DS2), 1).Columns.AutoFit
End With
End Sub

Em vừa thử thấy nó chạy ra đúng rồi bác ạ
Em cảm ơn bác rất nhiều ạ
Em sẽ thử với nhiều dữ liệu hơn xem sao ạ

hocexcel_1991 · 30/8/24

Thử bài này với công thức.

Mã:

=LET(t,G4:H10,UNIQUE(MAP(A4:A19,LAMBDA(m,TEXTJOIN("/",,UNIQUE(SORT(TOCOL(FILTER(t,MMULT(N(t=m),{1;1}),m)))))))))

Shaa · 30/8/24

hocexcel_1991 đã viết:
Thử bài này với công thức.

Mã:

=LET(t,G4:H10,UNIQUE(MAP(A4:A19,LAMBDA(m,TEXTJOIN("/",,UNIQUE(SORT(TOCOL(FILTER(t,MMULT(N(t=m),{1;1}),m)))))))))

View attachment 303593

office 2016 của em khi chạy sẽ báo công thức không tồn tại bác ạ. bác dùng bản nào thế ạ

hocexcel_1991 · 30/8/24

Shaa đã viết:
office 2016 của em khi chạy sẽ báo công thức không tồn tại bác ạ. bác dùng bản nào thế ạ

Công thức này dùng cho excel 365 thôi.

bebo021999 · 30/8/24

Post xong mới thấy chậm hơn CHAOQUAY.
Bụng đang đói mà lại làm về chủ đề này nên bị phân tâm

PHP:

Option Explicit
Sub monan()
Dim lr&, i&, j&, k&, t&, s As String, ds1, ds3, sp
Dim ds2(1 To 10000, 1 To 1), arr(1 To 10000, 1 To 2)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
ds1 = Range("A4:A" & Range("A4").End(xlDown).Row).Value
lr = Range("G4").End(xlDown).Row
ds3 = Range("G4:H" & lr).Value
For i = 1 To UBound(ds3)
    For j = 1 To 2
        s = ds3(i, IIf(j = 1, 2, 1))
        If Not dic.exists(ds3(i, j)) Then
            dic.Add ds3(i, j), "/" & ds3(i, j) & "/" & s
            k = k + 1: arr(k, 1) = ds3(i, j): arr(k, 2) = dic(ds3(i, j))
        Else
            dic(ds3(i, j)) = dic(ds3(i, j)) & "/" & s
            For t = 1 To k
                If arr(t, 1) = ds3(i, j) Then arr(t, 2) = dic(ds3(i, j))
            Next
        End If
    Next
Next
dic.RemoveAll: t = 0
For i = 1 To k
    For j = 1 To k
        If i <> j And InStr(1, arr(j, 2), "/" & arr(i, 1)) Then
            arr(i, 2) = arr(i, 2) & arr(j, 2)
        End If
    Next
Next
For i = 1 To k
    sp = Split(arr(i, 2), "/"): s = ""
    For j = 1 To UBound(sp)
        If Not dic.exists(sp(j)) Then
            dic.Add sp(j), ""
            s = IIf(s = "", "", s & "/") & sp(j)
        End If
    Next
    If s <> "" Then
        t = t + 1: ds2(t, 1) = s
    End If
Next
For i = 1 To UBound(ds1)
    If WorksheetFunction.CountIf(Range("G4:H" & lr), ds1(i, 1)) = 0 Then
        t = t + 1: ds2(t, 1) = ds1(i, 1)
    End If
Next
If t > 0 Then
    With Range("D4")
        .Resize(10000, 1).ClearContents
        .Resize(t, 1).Value = ds2
    End With
End If
Set dic = Nothing
End Sub

Shaa · 30/8/24

bebo021999 đã viết:

Post xong mới thấy chậm hơn CHAOQUAY.
Bụng đang đói mà lại làm về chủ đề này nên bị phân tâm

PHP:

Option Explicit
Sub monan()
Dim lr&, i&, j&, k&, t&, s As String, ds1, ds3, sp
Dim ds2(1 To 10000, 1 To 1), arr(1 To 10000, 1 To 2)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
ds1 = Range("A4:A" & Range("A4").End(xlDown).Row).Value
lr = Range("G4").End(xlDown).Row
ds3 = Range("G4:H" & lr).Value
For i = 1 To UBound(ds3)
    For j = 1 To 2
        s = ds3(i, IIf(j = 1, 2, 1))
        If Not dic.exists(ds3(i, j)) Then
            dic.Add ds3(i, j), "/" & ds3(i, j) & "/" & s
            k = k + 1: arr(k, 1) = ds3(i, j): arr(k, 2) = dic(ds3(i, j))
        Else
            dic(ds3(i, j)) = dic(ds3(i, j)) & "/" & s
            For t = 1 To k
                If arr(t, 1) = ds3(i, j) Then arr(t, 2) = dic(ds3(i, j))
            Next
        End If
    Next
Next
dic.RemoveAll: t = 0
For i = 1 To k
    For j = 1 To k
        If i <> j And InStr(1, arr(j, 2), "/" & arr(i, 1)) Then
            arr(i, 2) = arr(i, 2) & arr(j, 2)
        End If
    Next
Next
For i = 1 To k
    sp = Split(arr(i, 2), "/"): s = ""
    For j = 1 To UBound(sp)
        If Not dic.exists(sp(j)) Then
            dic.Add sp(j), ""
            s = IIf(s = "", "", s & "/") & sp(j)
        End If
    Next
    If s <> "" Then
        t = t + 1: ds2(t, 1) = s
    End If
Next
For i = 1 To UBound(ds1)
    If WorksheetFunction.CountIf(Range("G4:H" & lr), ds1(i, 1)) = 0 Then
        t = t + 1: ds2(t, 1) = ds1(i, 1)
    End If
Next
If t > 0 Then
    With Range("D4")
        .Resize(10000, 1).ClearContents
        .Resize(t, 1).Value = ds2
    End With
End If
Set dic = Nothing
End Sub

Tuyệt vời quá
Em cảm ơn bác rất nhiều ạ

Nhờ giúp đỡ code tạo danh sách mới từ một danh sách ban đầu và danh sách điều kiện

Shaa

Thành viên mới

File đính kèm

hoangtuaotrang_hp_vn

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

File đính kèm

CHAOQUAY

Thành viên gắn bó

Shaa

Thành viên mới

hocexcel_1991

Bắt đầu học Excel

Shaa

Thành viên mới

hocexcel_1991

Bắt đầu học Excel

bebo021999

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

File đính kèm

Shaa

Thành viên mới

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