Сбор списка общих точек

Question

Я пытаюсь сделать что-то, что, вероятно, просто, но я изо всех сил пытаюсь найти решение. У меня есть список пар номеров точек (например, для точки 343 в паре с номером 494 у меня есть элемент списка с именем "343/494"). Список может выглядеть примерно так:

array(0) = "343/494"
array(1) = "989/282"
array(2) = "343/112"
array(3) = "282/343"
array(4) = "282/9991"

Я хочу создать новый массив с записями, которые имеют общий номер, но имеют только две записи. Это будет выглядеть следующим образом:

new_array(0,0) = "343/494"
new_array(0,1) ="343/112" 

(обратите внимание, что «282/343» опущено, потому что уже есть две записи, разделяющие «343»)

new_array(1,0) = "989/282"
new_array(1,1) = "282/343"

(как и вышенужны только две записи, содержащие что-то с «282»)

Поскольку уникальных дубликатов других значений не существует, я не создаю их, помещая их в new_array

Это большая частьчто я пытаюсь сделать

Буду очень признателен за любые предложения

Answer 1

Вы можете использовать:

    Option Explicit

    Sub test()

        Dim arrIni As Variant, arrResult(1) As Variant
        Dim valueIni_1 As String, valueIni_2 As String, valueRes_1 As String, valueRes_2 As String
        Dim i As Long, j As Long, Counter As Long, LastRow As Long

        arrIni = Array("343/494", "989/282", "343/112", "282/343", "282/9991")

        For i = LBound(arrIni) To UBound(arrIni)

            Counter = 0

            valueIni_1 = Split(arrIni(i), "/")(0)
            valueIni_2 = Split(arrIni(i), "/")(1)

            For j = LBound(arrIni) To UBound(arrIni)

                valueRes_1 = Split(arrIni(j), "/")(0)
                valueRes_2 = Split(arrIni(j), "/")(1)

                If (valueIni_1 = valueRes_1) Or (valueIni_1 = valueRes_2) Or (valueIni_2 = valueRes_1) Or (valueIni_2 = valueRes_2) Then

                    Counter = Counter + 1

                    If Counter = 1 Then
                        arrResult(Counter - 1) = arrIni(i)
                    Else
                        arrResult(Counter - 1) = arrIni(j)
                    End If

                    If Counter = 2 Then
                        'Print result in sheet1
                        With ThisWorkbook.Worksheets("Sheet1")

                            LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

                            .Range("A" & LastRow + 2 & ":A" & LastRow + 3).Value = Application.WorksheetFunction.Transpose(arrResult)

                        End With

                        Exit For
                    End If

                End If

            Next j

        Next i

    End Sub

Результат: