Декартово произведение

[Посетитель 03.09.2024]

Здравствуйте, помогите пожалуйста, изменить код, для VBA на основании таблиц R1 и R3, должно быть сделано операция Декартово произведение

Представлены изображение где присутствует R1 и R3 и другое изображение где представлено как должно быть
Скидываю если что сам excel файл там представлено ручная и лабораторная №1 изменить надо только лабораторная №1

Также скидываю код

Sub Start()
    Dim A() As String
    Dim B() As String
    Dim ASB() As String
    Dim AUB() As String
    Dim ADiff() As String
    Dim AProd() As String
    Dim n As Integer, m As Integer
    Dim i As Integer, k1 As Integer, k2 As Integer, kDiff As Integer, kProd As Integer
 
    ' ?????????? ?????? ?? ?????
    i = 3
    Do
        If Cells(i, 2).Value = "" Then
            n = i - 3
            Exit Do
        End If
        i = i + 1
    Loop
   
    If n = 0 Then
        MsgBox "??? ?????? ? ??????? A"
        Exit Sub
    End If
   
    i = 3
    Do
        If Cells(i, 4).Value = "" Then
            m = i - 3
            Exit Do
        End If
        i = i + 1
    Loop
   
    If m = 0 Then
        MsgBox "??? ?????? ? ??????? B"
        Exit Sub
    End If
   
    ' ????????????? ????????
    ReDim A(1 To n, 1 To 2) As String
    ReDim B(1 To m, 1 To 2) As String
    ReDim ASB(1 To n + m, 1 To 2) As String
    ReDim AUB(1 To n + m, 1 To 2) As String
    ReDim ADiff(1 To n, 1 To 2) As String
    ReDim AProd(1 To n * m, 1 To 2) As String
 
    ' ?????????? ???????? A ? B
    For i = 1 To n
        A(i, 1) = Cells(i + 2, 2)
        A(i, 2) = Cells(i + 2, 3)
    Next i
   
    For i = 1 To m
        B(i, 1) = Cells(i + 2, 4)
        B(i, 2) = Cells(i + 2, 5)
    Next i
   
    ' ??????? ???????? ??? ?????? ???????????
    Range("F6:I40").ClearContents
 
    ' ???????? ???????????
    Intersect A, B, ASB, k1
 
    ' ???????? ???????????
    Union A, B, AUB, k2
 
    ' ???????? ????????
    Difference A, B, ADiff, kDiff
 
    ' ???????? ????????????
    CartesianProduct A, B, AProd, kProd
 
    ' ?????? ??????????? ? ????
    ' ???????????
    For i = 1 To k1
        Cells(i + 2, 6) = ASB(i, 1)
        Cells(i + 2, 7) = ASB(i, 2)
    Next i
 
    ' ???????????
    For i = 1 To k2
        Cells(i + 2, 8) = AUB(i, 1)
        Cells(i + 2, 9) = AUB(i, 2)
    Next i
   
    ' ????????
    For i = 1 To kDiff
        Cells(i + 2, 10) = ADiff(i, 1)
        Cells(i + 2, 11) = ADiff(i, 2)
    Next i
   
    ' ????????????
    For i = 1 To kProd
        Cells(i + 2, 12) = AProd(i, 1)
        Cells(i + 2, 13) = AProd(i, 2)
    Next i
End Sub
 
Sub Intersect(A() As String, B() As String, AB() As String, k As Integer)
    k = 0
    For i = 1 To UBound(A, 1)
        Dim aa As String
        Dim a1 As String
        aa = A(i, 1)
        a1 = A(i, 2)
        Dim q As Integer
        q = 0
        For j = 1 To UBound(B, 1)
            If B(j, 1) = aa Then
                q = -1
                Exit For
            End If
        Next j
        If (q <> 0) Then
            q = 0
            For j = 1 To k
                If AB(j, 1) = aa Then
                    q = -1
                    Exit For
                End If
            Next j
            If (q = 0) Then
                k = k + 1
                AB(k, 1) = aa
                AB(k, 2) = a1
            End If
        End If
    Next i
End Sub
 
Sub Union(A() As String, B() As String, AUB() As String, k As Integer)
 
    k = 0
    ' ?????????? ????????? ?? A
    For i = 1 To UBound(A, 1)
        k = k + 1
        AUB(k, 1) = A(i, 1)
        AUB(k, 2) = A(i, 2)
    Next i
    ' ?????????? ?????????? ????????? ?? B
    For j = 1 To UBound(B, 1)
        Dim isUnique As Boolean
        isUnique = True
        For i = 1 To k
            If AUB(i, 1) = B(j, 1) Then
                isUnique = False
                Exit For
            End If
        Next i
        If isUnique Then
            k = k + 1
            AUB(k, 1) = B(j, 1)
            AUB(k, 2) = B(j, 2)
        End If
    Next j
End Sub
 
Sub Difference(A() As String, B() As String, ADiff() As String, k As Integer)
    k = 0
    ' ?????????? ????????? ?? A, ??????? ??? ? B
    For i = 1 To UBound(A, 1)
        Dim isUnique As Boolean
        isUnique = True
        For j = 1 To UBound(B, 1)
            If B(j, 1) = A(i, 1) Then
                isUnique = False
                Exit For
            End If
        Next j
        If isUnique Then
            k = k + 1
            ADiff(k, 1) = A(i, 1)
            ADiff(k, 2) = A(i, 2)
        End If
    Next i
End Sub




Основная проблема в этом

Sub CartesianProduct(A() As String, B() As String, AProd() As String, k As Integer)
    k = 0
    ' ???????? ??????????? ????????????
    For i = 1 To UBound(A, 1)
        For j = 1 To UBound(B, 1)
            k = k + 1
            AProd(k, 1) = A(i, 1) & " " & B(j, 1)
            AProd(k, 2) = A(i, 2) & " " & B(j, 2)
        Next j
    Next i
End Sub


Заранее буду благодарен

P.S Пожалуйста, если нет варианта решение, не спамьте ненужными сообщением темы, перед тем как я, обращаюсь в форум, всегда пробуй различные варианты решение. Заранее благодарю за понимание