none
Incrementada no For RRS feed

  • Pergunta

  • 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
    

    domingo, 16 de junho de 2013 21:27

Respostas

  • 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

    • Marcado como Resposta carlito_penna quarta-feira, 19 de junho de 2013 20:16
    quarta-feira, 19 de junho de 2013 19:08
    Moderador

Todas as Respostas

  • 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.

    domingo, 16 de junho de 2013 22:53
  • 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.




    segunda-feira, 17 de junho de 2013 02:20
  • 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

    segunda-feira, 17 de junho de 2013 09:42
    Moderador
  • 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

    segunda-feira, 17 de junho de 2013 10:20
  • 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

    terça-feira, 18 de junho de 2013 23:03
    Moderador
  • 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)

    terça-feira, 18 de junho de 2013 23:41
  • 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

    • Marcado como Resposta carlito_penna quarta-feira, 19 de junho de 2013 20:16
    quarta-feira, 19 de junho de 2013 19:08
    Moderador
  • Perfeito, meus agradecimentos.
    quarta-feira, 19 de junho de 2013 20:14