Sub io()
    Dim rngSource   As Range
    Dim rngTarget   As Range
    Dim cell        As Range
    Dim i           As Long
    Dim ncnt        As Long
    
    Set rngSource = Range("A1:D15")
    
    Set rngTarget = Range("W1:AA1")
    rngTarget.Resize(1000).ClearContents
    rngTarget = Array("state1", "state2", "state3", "state4", "POVTOROV")

    'A&B
    For Each cell In Range("G2:G15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(2) = rngSource.Cells(cell.row, 2)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'A&C
    For Each cell In Range("I2:I15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(3) = rngSource.Cells(cell.row, 3)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'A&D
    For Each cell In Range("K2:K15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(4) = rngSource.Cells(cell.row, 4)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'A&D&B
    For Each cell In Range("M2:M15")
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            rngTarget.Cells(1) = rngSource.Cells(cell.row, 1)
            rngTarget.Cells(2) = rngSource.Cells(cell.row, 2)
            rngTarget.Cells(4) = rngSource.Cells(cell.row, 4)
            rngTarget.Cells(5) = cell.Value
        End If
    Next
    
    'переопределяем диапазон в соответствии со всеми выведенными строками
    Set rngTarget = rngTarget.Offset(-rngTarget.row + 1).Resize(rngTarget.row)

    'чистка повторов - если выше есть точно такая же строка, текущая вычищается
    '(с использованием функции СЧЁТЕСЛИМН, вычисляющей кол-во выше текущей строки)
    For i = 3 To rngTarget.Rows.Count
        ncnt = WorksheetFunction.CountIfs( _
                Range(rngTarget.Cells(1, 1), rngTarget.Cells(i - 1, 1)), "=" & rngTarget.Cells(i, 1), _
                Range(rngTarget.Cells(1, 2), rngTarget.Cells(i - 1, 2)), "=" & rngTarget.Cells(i, 2), _
                Range(rngTarget.Cells(1, 3), rngTarget.Cells(i - 1, 3)), "=" & rngTarget.Cells(i, 3), _
                Range(rngTarget.Cells(1, 4), rngTarget.Cells(i - 1, 4)), "=" & rngTarget.Cells(i, 4))
        If ncnt > 0 Then rngTarget.Rows(i).ClearContents
    Next i
    
    'удаление пустых строк (ранее очищенных) - движемся снизу вверх
    For i = rngTarget.Rows.Count To 3 Step -1
        If IsEmpty(rngTarget.Cells(i, 5)) Then
            rngTarget.Rows(i).Delete Shift:=xlUp
        End If
    Next i

End Sub

Option Explicit

Dim rngSource   As Range
Dim rngTarget   As Range

'подпрограмма обработки комбинаций типа A&B, A&C и т.д.
Sub doCombi(strRangeAddr, arrCols)

    Dim cell    As Range
    Dim col     As Variant 'Long
    
    For Each cell In Range(strRangeAddr)
        If cell.Value > 1 Then
            Set rngTarget = rngTarget.Offset(1)
            For Each col In arrCols
                rngTarget.Cells(col) = rngSource.Cells(cell.row, col)
            Next col
            rngTarget.Cells(5) = cell.Value
        End If
    Next

End Sub

'ГЛАВНАЯ ПРОГРАММА, которую надо запускать
Sub io_v2()

    Dim i       As Long
    Dim ncnt    As Long
    
    Set rngSource = Range("A1:D15")
    
    Set rngTarget = Range("W1:AA1")
    rngTarget.Resize(1000).ClearContents
    rngTarget = Array("state1", "state2", "state3", "state4", "POVTOROV")

    'читаем повторяющиеся комбинации
    'A&B
    doCombi "G2:G15", Array(1, 2)
    
    'A&C
    doCombi "I2:I15", Array(1, 3)
    
    'A&D
    doCombi "K2:K15", Array(1, 4)
    
    'A&D&B
    doCombi "M2:M15", Array(1, 2, 4)
       
       
    'переопределяем диапазон в соответствии со всеми выведенными строками
    Set rngTarget = rngTarget.Offset(-rngTarget.row + 1).Resize(rngTarget.row)

    'чистка повторов - если выше есть точно такая же строка, текущая вычищается
    '(с использованием функции СЧЁТЕСЛИМН, вычисляющей кол-во выше текущей строки)
    For i = 3 To rngTarget.Rows.Count
        ncnt = WorksheetFunction.CountIfs( _
                Range(rngTarget.Cells(1, 1), rngTarget.Cells(i - 1, 1)), "=" & rngTarget.Cells(i, 1), _
                Range(rngTarget.Cells(1, 2), rngTarget.Cells(i - 1, 2)), "=" & rngTarget.Cells(i, 2), _
                Range(rngTarget.Cells(1, 3), rngTarget.Cells(i - 1, 3)), "=" & rngTarget.Cells(i, 3), _
                Range(rngTarget.Cells(1, 4), rngTarget.Cells(i - 1, 4)), "=" & rngTarget.Cells(i, 4))
        If ncnt > 0 Then rngTarget.Rows(i).ClearContents
    Next i
    
    'удаление пустых строк (ранее очищенных) - движемся снизу вверх
    For i = rngTarget.Rows.Count To 3 Step -1
        If IsEmpty(rngTarget.Cells(i, 5)) Then
            rngTarget.Rows(i).Delete Shift:=xlUp
        End If
    Next i

End Sub

Sub Макрос2()
    Dim arr, arr_rez, a, b1, b2, c1, c2, d1, d2, s1 As String, s2 As String, s3 As String, n As Long, m As Long, k As Long, sd As Object
    Set sd = CreateObject("Scripting.Dictionary")
    arr = Range("A2:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    k = 0
    For n = 1 To UBound(arr)
        a = arr(n, 1)
        b1 = arr(n, 2): b2 = ""
        c1 = arr(n, 3): c2 = ""
        d1 = arr(n, 4): d2 = ""
        s2 = "": s3 = ""
        s1 = a & "|" & b1 & "|" & c1 & "|" & d1
        
        If Not sd.Exists(s1) Then
            sd.Add s1, 1
        Else
            sd(s1) = CLng(sd(s1)) + 1
            If CLng(sd(s1)) = 2 Then k = k + 1
        End If
        
        For m = 1 To 3
            If m = 1 Then
                s2 = a & "|" & b2 & "|" & c2 & "|" & d1
                s3 = a & "|" & b1 & "|" & c1 & "|" & d2
            ElseIf m = 2 Then
                s2 = a & "|" & b2 & "|" & c1 & "|" & d2
                s3 = a & "|" & b1 & "|" & c2 & "|" & d1
            ElseIf m = 3 Then
                s2 = a & "|" & b1 & "|" & c2 & "|" & d2
                s3 = a & "|" & b2 & "|" & c1 & "|" & d1
            End If
            
            If Not sd.Exists(s2) Then
                sd.Add s2, 1
            Else
                sd(s2) = CLng(sd(s2)) + 1
                If CLng(sd(s2)) = 2 Then k = k + 1
            End If
            
            If Not sd.Exists(s3) Then
                sd.Add s3, 1
            Else
                sd(s3) = CLng(sd(s3)) + 1
                If CLng(sd(s3)) = 2 Then k = k + 1
            End If
        Next
    Next
    
    ReDim arr_rez(1 To k, 1 To 5)
    n = 1
    
    For Each a In sd
        If sd(a) > 1 Then
            arr_rez(n, 1) = Split(a, "|")(0)
            arr_rez(n, 2) = Split(a, "|")(1)
            arr_rez(n, 3) = Split(a, "|")(2)
            arr_rez(n, 4) = Split(a, "|")(3)
            arr_rez(n, 5) = sd(a)
            n = n + 1
        End If
    Next
    [v2].Resize(UBound(arr_rez), UBound(arr_rez, 2)) = arr_rez
    
End Sub

Sub Макрос4()
    Dim arr, arr_sh, arr_tmp1, arr_tmp2, n As Long, m As Long, i As Long, k As Long, clm As Byte, s As String, y
    clm = Application.InputBox(prompt:="Введите количество обрабатываемых столбцов от 3 до 5", Type:=1)
    Set sd_clm = CreateObject("Scripting.Dictionary")
    sd_clm.Add 3, 3
    sd_clm.Add 4, 7
    sd_clm.Add 5, 15
    
    If Not sd_clm.Exists(clm) Then MsgBox "Неверный ввод": Exit Sub
    ReDim arr_sh(1 To CLng(sd_clm(clm)), 1 To clm)
    ReDim arr_tmp2(1 To clm)
    
    Set sd = CreateObject("Scripting.Dictionary")
   
    For n = 1 To CLng(sd_clm(clm))
        s = Application.WorksheetFunction.Dec2Bin(n, clm - 1)
        s = Replace(Replace(s, "0", "|0"), "1", "|1")
        arr_tmp1 = Split(s, "|")
        arr_sh(n, 1) = 1
        For m = 2 To clm
            arr_sh(n, m) = arr_tmp1(m - 1)
        Next
    Next
    
    i = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Range(Cells(2, 1), Cells(i, clm))
    For i = 1 To UBound(arr)
        For n = 1 To UBound(arr_sh)
            For m = 1 To UBound(arr_sh, 2)
                If arr_sh(n, m) = 1 Then
                    arr_tmp2(m) = arr(i, m)
                Else
                    arr_tmp2(m) = ""
                End If
            Next
            s = Join(arr_tmp2, "|")
            If Not sd.Exists(s) Then
                sd.Add s, 1
            Else
                sd(s) = CLng(sd(s)) + 1
                If CLng(sd(s)) = 2 Then k = k + 1
            End If
        Next
    Next
    
    ReDim arr_rez(1 To k, 1 To clm + 1)
    n = 1
    For Each y In sd
        If sd(y) > 1 Then
            arr_tmp1 = Split(y, "|")
            For m = 1 To UBound(arr_rez, 2) - 1
                arr_rez(n, m) = arr_tmp1(m - 1)
            Next
            arr_rez(n, UBound(arr_rez, 2)) = sd(y)
            n = n + 1
        End If
    Next
    
    [v2].Resize(UBound(arr_rez), UBound(arr_rez, 2)) = arr_rez
    [v1].Resize(1, UBound(arr_rez, 2) - 1) = [a1].Resize(1, UBound(arr_rez, 2) - 1).Value
    [v1].Offset(0, UBound(arr_rez, 2) - 1) = "POVTOROV"
End Sub