Liệt kê hoán vị chập 2 VBA

[snow25]

Cám ơn bạn đã quan tâm, nhưng code của bạn giúp ko chạy được

Sub GPE()
  Dim sArr As Variant, tArr(), dArr(), Res()
  Dim i As Long, j As Long, sRow As Long, n As Long, k As Long, q As Long, r As Long
  Dim tmp, fRow As Long
  Const sCol As Byte = 2

  i = Range("E" & Rows.Count).End(xlUp).Row
  If i > 2 Then Range("E2:F" & i).ClearContents
  sArr = Application.InputBox("Chon vung chua ket qua?", "Vung chua ket qua", Type:=8)
  If TypeName(sArr) = "Variant()" Then
    If UBound(sArr, 2) = sCol And UBound(sArr) >= 2 Then
      sRow = UBound(sArr)
      ReDim tArr(0 To sRow + 1, 1 To 2)
      For i = 1 To sRow
        tArr(i, 1) = sArr(i, 2)
        If tArr(i, 1) <> tArr(i - 1, 1) Then
          If k > 0 Then n = n + k * (k - 1)
          tArr(q, 2) = k
          q = i:          k = 1
        Else
          k = k + 1
        End If
      Next i
      n = n + k * (k - 1)
      tArr(q, 2) = k
      If n = 0 Or n > Rows.Count - 3 Then Exit Sub
    
      ReDim Res(1 To n, 1 To 2)
      k = 0
      For i = 1 To sRow
        n = tArr(i, 2)
        If n > 0 Then
          For r = i To i + n - 1
            For j = i To i + n - 1
              If j <> r Then
                k = k + 1
                Res(k, 1) = sArr(r, 1):       Res(k, 2) = sArr(j, 1)
              End If
            Next j
          Next r
        End If
      Next i
      Range("E2").Resize(UBound(Res), UBound(Res, 2)) = Res
    End If
  End If
End Sub

bác đấy tiện tay xóa mất mấy cái biến bạn xem có đúng không

 

[QuáchThiênLong]

Sub GPE()
  Dim sArr As Variant, tArr(), dArr(), Res()
  Dim i As Long, j As Long, sRow As Long, n As Long, k As Long, q As Long, r As Long
  Dim tmp, fRow As Long
  Const sCol As Byte = 2

  i = Range("E" & Rows.Count).End(xlUp).Row
  If i > 2 Then Range("E2:F" & i).ClearContents
  sArr = Application.InputBox("Chon vung chua ket qua?", "Vung chua ket qua", Type:=8)
  If TypeName(sArr) = "Variant()" Then
    If UBound(sArr, 2) = sCol And UBound(sArr) >= 2 Then
      sRow = UBound(sArr)
      ReDim tArr(0 To sRow + 1, 1 To 2)
      For i = 1 To sRow
        tArr(i, 1) = sArr(i, 2)
        If tArr(i, 1) <> tArr(i - 1, 1) Then
          If k > 0 Then n = n + k * (k - 1)
          tArr(q, 2) = k
          q = i:          k = 1
        Else
          k = k + 1
        End If
      Next i
      n = n + k * (k - 1)
      tArr(q, 2) = k
      If n = 0 Or n > Rows.Count - 3 Then Exit Sub
   
      ReDim Res(1 To n, 1 To 2)
      k = 0
      For i = 1 To sRow
        n = tArr(i, 2)
        If n > 0 Then
          For r = i To i + n - 1
            For j = i To i + n - 1
              If j <> r Then
                k = k + 1
                Res(k, 1) = sArr(r, 1):       Res(k, 2) = sArr(j, 1)
              End If
            Next j
          Next r
        End If
      Next i
      Range("E2").Resize(UBound(Res), UBound(Res, 2)) = Res
    End If
  End If
End Sub

bác đấy tiện tay xóa mất mấy cái biến bạn xem có đúng không

Thua rồi bạn ơi. Chắc phải làm thủ công thôi. Cám ơn bạn

 

[snow25]

Thua rồi bạn ơi. Chắc phải làm thủ công thôi. Cám ơn bạn

code vẫn chạy ngon mà bạn cho hình ảnh code nó báo lỗi ở đâu đi thì mới biết chứ,bạn cứ nói vậy ai biết được mà sửa

 

[HieuCD]

Cám ơn bạn đã quan tâm, nhưng code của bạn giúp ko chạy được

Code thêm thông báo
Nhấn mặt cười chạy code