Este fórum está sendo desativado

[EloN]

Boa tarde:
Preciso de um procedimento em VBA para combinar as 10 primeiras letras do alfabeto, seis a seis.

[JCabral]

Veja se resolve.

Código original daqui : http://www.vbaexpress.com/forum/showthr ... o-repeats)

Código: Selecionar todos

Option Explicit
Option Base 1

Sub Test1()
    Dim iNumber As Long
    Dim iCol As Long, iRow As Long
    Dim s As String
    Dim i As Long, j As Long
    Dim aIndex() As Long
    Dim aData() As Variant
    Dim bDone  As Boolean
    
    
    iNumber = 10
    
    ReDim aData(1 To iNumber)
    aData = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
    
    
    'clear working area
    ActiveSheet.Cells(1, 1).CurrentRegion.ClearContents
    
    'columns = C(iNumber, iCol)
    For iCol = 1 To iNumber
    
        'start in first row of iCol
        iRow = 1
    
        'add C(N, iCol) as header
        ActiveSheet.Cells(iRow, iCol).Value = "C(" & iNumber & "," & iCol & ")"
    
        
        Select Case iCol
            Case 1
                For i = 1 To iNumber
                    ActiveSheet.Cells(i + 1, iCol).Value = "{" & aData(i) & "}"
                Next i
            
            Case iNumber
                s = vbNullString
                For i = 1 To iNumber - 1
                    s = s & aData(i) & ","
                Next i
                ActiveSheet.Cells(2, iCol).Value = "{" & s & aData(iNumber) & "}"
            
            Case Else
                'init the index array to hold starting positions (1) and the max positon (2)
                'N = 12, T = 4
                'ABCDEFGHIJKL
                '        ^^^^ so N-T+1 = 9,10,11,12 or I,J,K,L
                ReDim aIndex(1 To iCol, 1 To 2)
                For i = 1 To iCol
                    aIndex(i, 1) = i
                    aIndex(i, 2) = iNumber - iCol + i
                Next i
            
                bDone = False
            
                While Not bDone
                
                    'do first one
                    s = aData(aIndex(1, 1))
                
                    For i = 2 To iCol
                        s = s & "," & aData(aIndex(i, 1))
                    Next i
                    
                    iRow = iRow + 1
                    ActiveSheet.Cells(iRow, iCol).Value = "{" & s & "}"
            
            
                    If aIndex(iCol, 1) <> aIndex(iCol, 2) Then
                        aIndex(iCol, 1) = aIndex(iCol, 1) + 1
                    Else
                        j = iCol
                        While aIndex(j, 1) = aIndex(j, 2) And j > 0
                            j = j - 1
                            If j = 0 Then GoTo NextCol  '   <<<<<<<<<
                        Wend
                        
                        'bump the highest order, not-maxed out index
                        aIndex(j, 1) = aIndex(j, 1) + 1
                                                            
                                                                                
                        For i = j + 1 To iCol
                            aIndex(i, 1) = aIndex(i - 1, 1) + 1
                        Next i
                    End If
            
            
            
                    'when the first index exceeds the last possible starting position, we're done
                    If aIndex(1, 1) > aIndex(1, 2) Then bDone = True
                Wend
            
        End Select
    
            
    
NextCol:
        
        With ActiveSheet.Cells(1, iCol).End(xlDown).Offset(1, 0)
            .Value = (.Row - 2) & " Comb"
        End With
    
    Next iCol

End Sub