Incrementada no For

Question

Boa noite

O código abaixo, é de autoria do Acao do fórum Vba, portugal-a-programar. O código funciona perfeitamente mas preciso aumentar as atuais 255 linhas geradas para 10000 linhas. 

Grato

Option Explicit
Dim vRangTab As Range
Dim vQtdNumParEImpar() As Integer
Dim vRowsTab As Integer
Dim vColsTab As Integer
Dim vNumPorRows() As Integer
Dim vQtdNumsRows() As Integer
Dim vRows As Integer

Private Sub CommandButton1_Click()
On Error Resume Next
Dim vNum As Integer
Dim vQtdNumPar As Integer
Dim vQtdNumImpar As Integer
Dim vNumEpar As Boolean
Dim vRangTabCol As Range
Dim vRangCols As Range
Dim vRangRows As Range
Dim vNumAleatorios() As Integer
Dim vNumPorLinha() As Integer
Dim vExitNaRow As Boolean
Dim vValInvalido As Boolean
Dim vContadorCols As Integer
Dim vAAleatorioRow As Integer
Dim vContadorRows As Integer
Dim vii As Integer
Dim vContador As Integer
Dim vContinuaProc As Boolean
Dim vExitArray10 As Boolean
Dim vRepetir As Byte
Dim vMsgErr As Boolean

ActiveWorkbook.Sheets("Plan1").Activate
vRows = 255
Set vRangTab = Range("A1:J3")
Range("A5:J300").Value = ""
If vRows > 255 Then

Exit Sub
End If
vColsTab = 0
vRowsTab = 0
For Each vRangCols In vRangTab.Columns
        vColsTab = vColsTab + 1
Next vRangCols
For Each vRangRows In vRangTab.Rows
        vRowsTab = vRowsTab + 1
Next vRangRows
Call CarregaQtdNumPorLinha
Call CarregaNumParEImpares
vMsgErr = False
        For vAAleatorioRow = 1 To vRows
                For vRepetir = 1 To 5
                        ReDim vNumAleatorios(vNumPorRows(vAAleatorioRow) - 1)
                        vQtdNumPar = vQtdNumParEImpar(vAAleatorioRow - 1, 0)
                        vQtdNumImpar = vQtdNumParEImpar(vAAleatorioRow - 1, 1)
                        vContadorCols = -1
                        vContador = 0
                                For Each vRangTabCol In vRangTab.Columns
                                        vContadorCols = vContadorCols + 1
                                        vContador = 0
                                        vContadorRows = 0
                                        Do
                                                vValInvalido = True
                                                vContador = vContador + 1
                                                If vContador <= 200 Then
                                                        vNum = WorksheetFunction.RandBetween(1, vRowsTab)
                                                        vNum = vRangTabCol.Cells(vNum, 1).Value
                                                    Else
                                                          vContadorRows = vContadorRows + 1
                                                        If vContadorRows <= vRowsTab Then
                                                                vNum = vRangTabCol.Cells(vContadorRows, 1)
                                                        Else
                                                                Dim hj As Integer
                                                                For hj = 1 To UBound(vNumAleatorios) + 1
                                                                        Cells(8 + vAAleatorioRow, hj).Value = ""
                                                                        
                                                                Next hj
                                                                If vRepetir > 4 Then
                                                                        vMsgErr = True
                                                                Else
                                                                        vContadorCols = vContadorCols - 1
                                                                End If
                                                                Exit For
                                                        End If
                                                End If
                                                If vNum Mod 2 = 0 Then
                                                        If vQtdNumPar > 0 Then
                                                                vContinuaProc = True
                                                        Else
                                                                vContinuaProc = False
                                                        End If
                                                Else
                                                        If vQtdNumImpar > 0 Then
                                                                vContinuaProc = True
                                                        Else
                                                                vContinuaProc = False
                                                        End If
                                                End If
                                                If vContinuaProc = True Then
                                                        vExitArray10 = False
                                                        For vii = LBound(vNumAleatorios) To UBound(vNumAleatorios)
                                                                If vNum = vNumAleatorios(vii) Then
                                                                        vExitArray10 = True
                                                                        Exit For
                                                                End If
                                                        Next vii
                                                        If vExitArray10 = False Then
                                                                vValInvalido = False
                                                                If vNum Mod 2 = 0 Then
                                                                        vQtdNumPar = vQtdNumPar - 1
                                                                Else
                                                                        vQtdNumImpar = vQtdNumImpar - 1
                                                                End If
                                                        End If
                                                End If
                                        Loop While vValInvalido
                                vNumAleatorios(vContadorCols) = vNum
                                Cells(4 + vAAleatorioRow, vContadorCols + 1).Value = vNum
                                If vContadorCols = UBound(vNumAleatorios) Then
                                        Exit For
                                End If
                                Next
                If vContadorCols = UBound(vNumAleatorios) Then
                        Exit For
                End If
                Next vRepetir
        Next vAAleatorioRow
        If vMsgErr = True Then
                MsgBox "Não foi possivel gerar todas as linhas."
        End If
    
End Sub

Public Sub CarregaQtdNumPorLinha()
ReDim vQtdNumsRows(1 To 10)
ReDim vNumPorRows(1 To vRows)

vQtdNumsRows(1) = 10
vQtdNumsRows(2) = 10
vQtdNumsRows(3) = 10
vQtdNumsRows(4) = 10
vQtdNumsRows(5) = 10
vQtdNumsRows(6) = 10
vQtdNumsRows(7) = 10
vQtdNumsRows(8) = 10
vQtdNumsRows(9) = 10
vQtdNumsRows(10) = 10

im i As Integer
For i = 1 To vRows
               
        If i <= 10 Then
                If vQtdNumsRows(i) > 0 And vQtdNumsRows(i) <= vColsTab Then
                        vNumPorRows(i) = vQtdNumsRows(i)
                Else
                vNumPorRows(i) = vColsTab
                End If
        Else
        vNumPorRows(i) = vColsTab
        End If
Next i
End Sub

Public Sub CarregaNumParEImpares()
Dim vQtdNumParPorRow(1 To 12) As Integer
Dim vQtdNumImparPorRow(1 To 13) As Integer
Dim vI As Byte

vQtdNumParPorRow(1) = 12
vQtdNumParPorRow(2) = 12
vQtdNumParPorRow(3) = 12
vQtdNumParPorRow(4) = 12
vQtdNumParPorRow(5) = 12
vQtdNumParPorRow(6) = 12
vQtdNumParPorRow(7) = 12
vQtdNumParPorRow(8) = 12
vQtdNumParPorRow(9) = 12
vQtdNumParPorRow(10) = 12

vQtdNumImparPorRow(1) = 13
vQtdNumImparPorRow(2) = 13
vQtdNumImparPorRow(3) = 13
vQtdNumImparPorRow(4) = 13
vQtdNumImparPorRow(5) = 13
vQtdNumImparPorRow(6) = 13
vQtdNumImparPorRow(7) = 13
vQtdNumImparPorRow(8) = 13
vQtdNumImparPorRow(9) = 13
vQtdNumImparPorRow(10) = 13

ReDim vQtdNumParEImpar(vRows - 1, 1)
For vI = 1 To vRows
        
        If vI <= 10 Then
                If vQtdNumParPorRow(vI) + vQtdNumImparPorRow(vI) = vNumPorRows(vI) Then
                        vQtdNumParEImpar(vI - 1, 0) = vQtdNumParPorRow(vI)
                        vQtdNumParEImpar(vI - 1, 1) = vQtdNumImparPorRow(vI)
                Else
                If vNumPorRows(vI) Mod 2 = 0 Then
                                vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                                vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2)
                        Else
                                vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                                vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2 + 1)
                        End If
                End If
        Else
                        If vNumPorRows(vI) Mod 2 = 0 Then
                        vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                        vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2)
                Else
                        vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                        vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2 + 1)
                End If
        End If
Next
End Sub

Private Sub CommandButton_Click_Click()

End Sub

Answer 1

Já perguntaste ao acao?

Não digo para não usares código de outros, apenas digo para observares o que o código faz de modo a não teres problemas futuros.

Se analizares o código irás concerteza saber mudar o valor 255 para 10000.

Answer 2

Meu caro Nando Freitas, deve estar se referindo a essa parte do código, fiz a alteração nessa parte do código e não deu muito certo.

ActiveWorkbook.Sheets("Plan1").Activate
vRows = 255
Set vRangTab = Range("A1:J3")
Range("A5:J300").Value = ""
If vRows > 255 Then

Tambem mexi aqui e não fui feliz

If vContador <= 200 Then

Queria esclarecer que esse código foi desenvolvido a meu pedido, o qual poderá ser facilmente comprovado em portugal a programar. Tenho vários pedidos de ajuda (Pennafortt) o qual a maioria foram atendidos e sempre cito a fonte dos códigos que posto.

Answer 3

Carlito, qual é o código original? O código que você postou retorna um erro. Além disso, o que é para o código fazer?

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 4

Bom dia

É informado no intervalo A1:H6, sequencias de números, o código "pega" um numero por vez de cada coluna e monta sequencias únicas sem repetição. Fiz algumas alterações no intervalo  e quantidade de linhas (255) e rodou normal. Eis o código original. 

Option Explicit
Dim vRangTab As Range
Dim vQtdNumParEImpar() As Integer
Dim vRowsTab As Integer
Dim vColsTab As Integer
Dim vNumPorRows() As Integer
Dim vQtdNumsRows() As Integer
Dim vRows As Integer

Private Sub CommandButton1_Click()
On Error Resume Next
Dim vNum As Integer
Dim vQtdNumPar As Integer
Dim vQtdNumImpar As Integer
Dim vNumEpar As Boolean
Dim vRangTabCol As Range
Dim vRangCols As Range
Dim vRangRows As Range
Dim vNumAleatoricos() As Integer
Dim vNumPorLinha() As Integer
Dim vExitNaRow As Boolean
Dim vValInvalido As Boolean
Dim vContadorCols As Integer
Dim vAleatoricoRow As Integer
Dim vContadorRows As Integer
Dim vii As Integer
Dim vContador As Integer
Dim vContinuaProc As Boolean
Dim vExitArray10 As Boolean
Dim vRepetir As Byte
Dim vMsgErr As Boolean
ActiveWorkbook.Sheets("Folha2").Activate
'................preencher....................................
vRows = 26 'quantidade de linhas <= 255
Set vRangTab = Range("A1:H6")  'rectificar o range de acordo com a tabela
Range("A9:H35").Value = ""     'rectificar o range de acordo com a zona de gerar os numeros para limpar
'.........................................................
If vRows > 255 Then
MsgBox "A quantidade de linhas tem que ser menor de 256."
Exit Sub
End If
vColsTab = 0
vRowsTab = 0
For Each vRangCols In vRangTab.Columns
        vColsTab = vColsTab + 1
Next vRangCols
For Each vRangRows In vRangTab.Rows
        vRowsTab = vRowsTab + 1
Next vRangRows
Call CarregaQtdNumPorLinha
Call CarregaNumParEImpares
vMsgErr = False
        For vAleatoricoRow = 1 To vRows 'Gera a quantidade de linhas
                For vRepetir = 1 To 5 ' se não conseguir concluir a linha com os parametros repete 5 vezes
                        ReDim vNumAleatoricos(vNumPorRows(vAleatoricoRow) - 1)
                        vQtdNumPar = vQtdNumParEImpar(vAleatoricoRow - 1, 0)
                        vQtdNumImpar = vQtdNumParEImpar(vAleatoricoRow - 1, 1)
                        vContadorCols = -1
                        vContador = 0
                                For Each vRangTabCol In vRangTab.Columns     'percorre as colunas do range
                                        vContadorCols = vContadorCols + 1
                                        vContador = 0
                                        vContadorRows = 0
                                        Do
                                                vValInvalido = True
                                                vContador = vContador + 1 'Conta as vezes de procura
                                                If vContador <= 200 Then 'procura aleatoricamente até 200 vezes
                                                        vNum = WorksheetFunction.RandBetween(1, vRowsTab) 'seleciona uma rows da tabela aleatoricamente
                                                        vNum = vRangTabCol.Cells(vNum, 1).Value   'atribui o valor da celula referente à rows de acordo com a coluna percorrida
                                                       
                                                Else
                                                'alternativa se não encontrou nas 200 vezes, percorre a coluna até ao fim e verifica se tem numeros que sirvam
                                                        vContadorRows = vContadorRows + 1
                                                        If vContadorRows <= vRowsTab Then
                                                                vNum = vRangTabCol.Cells(vContadorRows, 1)
                                                        Else
                                                        'se chegou ao fim sem encontrar, apaga a linha e começa de inicio até 5 vezes
                                                                Dim hj As Integer
                                                                For hj = 1 To UBound(vNumAleatoricos) + 1
                                                                        Cells(8 + vAleatoricoRow, hj).Value = "" 'apaga a linha
                                                                        
                                                                Next hj
                                                                If vRepetir > 4 Then ' na 5 passagem aciona a msg de erro que não concluiu a linha.
                                                                        vMsgErr = True
                                                                Else
                                                                        vContadorCols = vContadorCols - 1
                                                                End If
                                                                Exit For
                                                        End If
                                                End If
                                                If vNum Mod 2 = 0 Then
                                                        If vQtdNumPar > 0 Then
                                                                vContinuaProc = True
                                                        Else
                                                                vContinuaProc = False
                                                        End If
                                                Else
                                                        If vQtdNumImpar > 0 Then
                                                                vContinuaProc = True
                                                        Else
                                                                vContinuaProc = False
                                                        End If
                                                End If
                                                If vContinuaProc = True Then
                                                        ' verifica se já existe o numero na linha
                                                        vExitArray10 = False
                                                        For vii = LBound(vNumAleatoricos) To UBound(vNumAleatoricos)
                                                                If vNum = vNumAleatoricos(vii) Then
                                                                        vExitArray10 = True
                                                                        Exit For
                                                                End If
                                                        Next vii
                                                        If vExitArray10 = False Then
                                                                vValInvalido = False
                                                                If vNum Mod 2 = 0 Then
                                                                        vQtdNumPar = vQtdNumPar - 1
                                                                Else
                                                                        vQtdNumImpar = vQtdNumImpar - 1
                                                                End If
                                                        End If
                                                End If
                                        Loop While vValInvalido
                                vNumAleatoricos(vContadorCols) = vNum
                                Cells(8 + vAleatoricoRow, vContadorCols + 1).Value = vNum 'grava na folha com inicio na linha 9 e coluna 1
                                If vContadorCols = UBound(vNumAleatoricos) Then 'se já tem os numeros todos sai do for e começa nova linha
                                        Exit For
                                End If
                                Next
                If vContadorCols = UBound(vNumAleatoricos) Then 'se já tem os numeros todos sai do for e começa nova linha
                        Exit For
                End If
                Next vRepetir
        Next vAleatoricoRow
        If vMsgErr = True Then
                MsgBox "Não foi possivel gerar todas as linhas, verifique se o range está a selecionar zona sem dados."
        End If
    
End Sub
Public Sub CarregaQtdNumPorLinha()
ReDim vQtdNumsRows(1 To 10)
ReDim vNumPorRows(1 To vRows)
'''''''''''''''''''''''Preencher............
vQtdNumsRows(1) = 1 'quantidade de numeros por Linha
vQtdNumsRows(2) = 2 'quantidade de numeros por Linha
vQtdNumsRows(3) = 3 'quantidade de numeros por Linha
vQtdNumsRows(4) = 4 'quantidade de numeros por Linha
vQtdNumsRows(5) = 5 'quantidade de numeros por Linha
vQtdNumsRows(6) = 6 'quantidade de numeros por Linha
vQtdNumsRows(7) = 7 'quantidade de numeros por Linha
vQtdNumsRows(8) = 8 'quantidade de numeros por Linha
vQtdNumsRows(9) = 9 'quantidade de numeros por Linha
vQtdNumsRows(10) = 10 'quantidade de numeros por Linha
'.............................................
Dim i As Integer
For i = 1 To vRows
        'se a linha é <= 10 e a qtd numeros por linha é >0 e <= que a qtd de colunas atribuidas no range dos numeros dados pelo utilizador.
        'atribui o valor dado
        If i <= 10 Then
                If vQtdNumsRows(i) > 0 And vQtdNumsRows(i) <= vColsTab Then
                        vNumPorRows(i) = vQtdNumsRows(i)
                Else
                'senão atribui o valor = ao das colunas do range (utilizador)
                        vNumPorRows(i) = vColsTab
                End If
        Else
        'se a linha é > 10 atribui o valor = ao das colunas do range (utilizador)
                vNumPorRows(i) = vColsTab
        End If
Next i
End Sub
Public Sub CarregaNumParEImpares()
Dim vQtdNumParPorRow(1 To 10) As Integer
Dim vQtdNumImparPorRow(1 To 10) As Integer
Dim vI As Byte
'''''''''''''''''''''''Preencher............
vQtdNumParPorRow(1) = 3  'quantidade de numeros pares
vQtdNumParPorRow(2) = 3
vQtdNumParPorRow(3) = 3
vQtdNumParPorRow(4) = 3
vQtdNumParPorRow(5) = 3
vQtdNumParPorRow(6) = 3
vQtdNumParPorRow(7) = 3
vQtdNumParPorRow(8) = 3
vQtdNumParPorRow(9) = 3
vQtdNumParPorRow(10) = 3 'quantidade de numeros pares
'..........................................................
vQtdNumImparPorRow(1) = 5 'quantidade de numeros impares
vQtdNumImparPorRow(2) = 5
vQtdNumImparPorRow(3) = 5
vQtdNumImparPorRow(4) = 5
vQtdNumImparPorRow(5) = 5
vQtdNumImparPorRow(6) = 5
vQtdNumImparPorRow(7) = 5
vQtdNumImparPorRow(8) = 5
vQtdNumImparPorRow(9) = 5
vQtdNumImparPorRow(10) = 5 'quantidade de numeros impares
'............................................................
ReDim vQtdNumParEImpar(vRows - 1, 1)
For vI = 1 To vRows
        ' se a linha é <= que 10 e a  qtd numeros pares e impares é igual à qtd colunas
        If vI <= 10 Then
                If vQtdNumParPorRow(vI) + vQtdNumImparPorRow(vI) = vNumPorRows(vI) Then
                        vQtdNumParEImpar(vI - 1, 0) = vQtdNumParPorRow(vI)
                        vQtdNumParEImpar(vI - 1, 1) = vQtdNumImparPorRow(vI)
                Else
                ' senão atribui metade do valor de numeros por linha aos pares e +1 aos impares
                        If vNumPorRows(vI) Mod 2 = 0 Then
                                vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                                vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2)
                        Else
                                vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                                vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2 + 1)
                        End If
                End If
        Else
        'se a linha é maior que 10 atribui metade do valor de numeros por linha aos pares e +1 aos impares
                If vNumPorRows(vI) Mod 2 = 0 Then
                        vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                        vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2)
                Else
                        vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                        vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2 + 1)
                End If
        End If
Next
End Sub

Grato

Answer 5

Utilizando seu código, preenchi o intervalo que você mencionou com números, mas ao rodar a macro, apenas dois blocos de número foram gerados, totalizando menos que 255 números. É isso mesmo?

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 6

Estou enviando planilha com as alterações que fiz por conta própria e geração das 255 linhas.

(http://www.sendpace.com/file/a5npff)

Answer 7

Option Explicit

Const clngNumRows As Long = 1000

Dim vRangTab As Range
Dim vQtdNumParEImpar() As Long
Dim vRowsTab As Long
Dim vColsTab As Long
Dim vNumPorRows() As Long
Dim vQtdNumsRows() As Long
Dim vRows As Long

Private Sub CommandButton1_Click()

    Dim vNum As Long
    Dim vQtdNumPar As Long
    Dim vQtdNumImpar As Long
    Dim vNumEpar As Boolean
    Dim vRangTabCol As Range
    Dim vRangCols As Range
    Dim vRangRows As Range
    Dim vNumAleatorios() As Long
    Dim vNumPorLinha() As Long
    Dim vExitNaRow As Boolean
    Dim vValInvalido As Boolean
    Dim vContadorCols As Long
    Dim vAAleatorioRow As Long
    Dim vContadorRows As Long
    Dim vii As Long
    Dim vContador As Long
    Dim vContinuaProc As Boolean
    Dim vExitArray10 As Boolean
    Dim vRepetir As Long
    Dim vMsgErr As Boolean
    
'    On Error Resume Next

    vRows = clngNumRows
    Set vRangTab = Range("A1:J3")
    Range("A5:J" & ActiveSheet.Rows.Count).Value = ""
    
    If vRows > clngNumRows Then
    MsgBox "A quantidade de linhas tem que ser menor de " & clngNumRows + 1 & "."
    Exit Sub
    End If
    vColsTab = 0
    vRowsTab = 0
    For Each vRangCols In vRangTab.Columns
        vColsTab = vColsTab + 1
    Next vRangCols
    For Each vRangRows In vRangTab.Rows
        vRowsTab = vRowsTab + 1
    Next vRangRows
    Call CarregaQtdNumPorLinha
    Call CarregaNumParEImpares
    vMsgErr = False
        For vAAleatorioRow = 1 To vRows
            For vRepetir = 1 To 5
                ReDim vNumAleatorios(vNumPorRows(vAAleatorioRow) - 1)
                vQtdNumPar = vQtdNumParEImpar(vAAleatorioRow - 1, 0)
                vQtdNumImpar = vQtdNumParEImpar(vAAleatorioRow - 1, 1)
                vContadorCols = -1
                vContador = 0
                    For Each vRangTabCol In vRangTab.Columns
                        vContadorCols = vContadorCols + 1
                        vContador = 0
                        vContadorRows = 0
                        Do
                            vValInvalido = True
                            vContador = vContador + 1
                            If vContador <= 200 Then
                                vNum = WorksheetFunction.RandBetween(1, vRowsTab)
                                vNum = vRangTabCol.Cells(vNum, 1).Value
                               
                            Else
                            
                                vContadorRows = vContadorRows + 1
                                If vContadorRows <= vRowsTab Then
                                    vNum = vRangTabCol.Cells(vContadorRows, 1)
                                Else
                                
                                    Dim hj As Long
                                    For hj = 1 To UBound(vNumAleatorios) + 1
                                        Cells(8 + vAAleatorioRow, hj).Value = ""
                                        
                                    Next hj
                                    If vRepetir > 4 Then
                                        vMsgErr = True
                                    Else
                                        vContadorCols = vContadorCols - 1
                                    End If
                                    Exit For
                                End If
                            End If
                            If vNum Mod 2 = 0 Then
                                If vQtdNumPar > 0 Then
                                    vContinuaProc = True
                                Else
                                    vContinuaProc = False
                                End If
                            Else
                                If vQtdNumImpar > 0 Then
                                    vContinuaProc = True
                                Else
                                    vContinuaProc = False
                                End If
                            End If
                            If vContinuaProc = True Then
                               
                                vExitArray10 = False
                                For vii = LBound(vNumAleatorios) To UBound(vNumAleatorios)
                                    If vNum = vNumAleatorios(vii) Then
                                        vExitArray10 = True
                                        Exit For
                                    End If
                                Next vii
                                If vExitArray10 = False Then
                                    vValInvalido = False
                                    If vNum Mod 2 = 0 Then
                                        vQtdNumPar = vQtdNumPar - 1
                                    Else
                                        vQtdNumImpar = vQtdNumImpar - 1
                                    End If
                                End If
                            End If
                        Loop While vValInvalido
                    vNumAleatorios(vContadorCols) = vNum
                    Cells(4 + vAAleatorioRow, vContadorCols + 1).Value = vNum
                    If vContadorCols = UBound(vNumAleatorios) Then
                        Exit For
                    End If
                    Next
            If vContadorCols = UBound(vNumAleatorios) Then
                Exit For
            End If
            Next vRepetir
            DoEvents
        Next vAAleatorioRow
        If vMsgErr = True Then
            MsgBox "Não foi possivel gerar todas as linhas, verifique se o range está a selecionar zona sem dados."
        End If
    
    End Sub
Public Sub CarregaQtdNumPorLinha()
    ReDim vQtdNumsRows(1 To 10)
    ReDim vNumPorRows(1 To vRows)
    
    vQtdNumsRows(1) = 10
    vQtdNumsRows(2) = 10
    vQtdNumsRows(3) = 10
    vQtdNumsRows(4) = 10
    vQtdNumsRows(5) = 10
    vQtdNumsRows(6) = 10
    vQtdNumsRows(7) = 10
    vQtdNumsRows(8) = 10
    vQtdNumsRows(9) = 10
    vQtdNumsRows(10) = 10
    
    Dim i As Long
    For i = 1 To vRows
       
        
        If i <= 10 Then
            If vQtdNumsRows(i) > 0 And vQtdNumsRows(i) <= vColsTab Then
                vNumPorRows(i) = vQtdNumsRows(i)
            Else
            
                vNumPorRows(i) = vColsTab
            End If
        Else
       
            vNumPorRows(i) = vColsTab
        End If
    Next i
End Sub

Public Sub CarregaNumParEImpares()
    Dim vQtdNumParPorRow(1 To 10) As Long
    Dim vQtdNumImparPorRow(1 To 10) As Long
    Dim vI As Long
    
    vQtdNumParPorRow(1) = 12
    vQtdNumParPorRow(2) = 12
    vQtdNumParPorRow(3) = 12
    vQtdNumParPorRow(4) = 12
    vQtdNumParPorRow(5) = 12
    vQtdNumParPorRow(6) = 12
    vQtdNumParPorRow(7) = 12
    vQtdNumParPorRow(8) = 12
    vQtdNumParPorRow(9) = 12
    vQtdNumParPorRow(10) = 12
    
    vQtdNumImparPorRow(1) = 13
    vQtdNumImparPorRow(2) = 13
    vQtdNumImparPorRow(3) = 13
    vQtdNumImparPorRow(4) = 13
    vQtdNumImparPorRow(5) = 13
    vQtdNumImparPorRow(6) = 13
    vQtdNumImparPorRow(7) = 13
    vQtdNumImparPorRow(8) = 13
    vQtdNumImparPorRow(9) = 13
    vQtdNumImparPorRow(10) = 13
    
    ReDim vQtdNumParEImpar(vRows - 1, 1)
    For vI = 1 To vRows
        
        If vI <= 10 Then
            If vQtdNumParPorRow(vI) + vQtdNumImparPorRow(vI) = vNumPorRows(vI) Then
                vQtdNumParEImpar(vI - 1, 0) = vQtdNumParPorRow(vI)
                vQtdNumParEImpar(vI - 1, 1) = vQtdNumImparPorRow(vI)
            Else
            
                If vNumPorRows(vI) Mod 2 = 0 Then
                    vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                    vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2)
                Else
                    vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                    vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2 + 1)
                End If
            End If
        Else
        
            If vNumPorRows(vI) Mod 2 = 0 Then
                vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2)
            Else
                vQtdNumParEImpar(vI - 1, 0) = Int(vNumPorRows(vI) / 2)
                vQtdNumParEImpar(vI - 1, 1) = Int(vNumPorRows(vI) / 2 + 1)
            End If
        End If
    Next
End Sub

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 8

Perfeito, meus agradecimentos.