none
Incrementada em código RRS feed

  • Pergunta

  • Boa tarde

    O código postado nesse link, funciona 100% e é de autoria do benzadeus, o qual peço a gentileza de alterar o modo como os parâmetros são informados. Certo de poder contar mais uma vez com sua valiosa ajuda.

    Grato

    http://www.sendspace.com/file/c2488l


    quarta-feira, 13 de novembro de 2013 20:02

Respostas

  • Minha soluçao é:

    Option Explicit Sub CriarSequenciaAleatoriaUniforme() Dim iCtr As Long Dim lNum1 As Long Dim lNum2 As Long Dim Temp As Variant Dim lRows As Long Dim lCols As Long Dim lCol As Long lRows = 10000 'quantidade de linhas lCols = 3 'quantidade de colunas Call fncMain(lCols, lRows) 'Inicia a planilha     For lCol = 1 To lCols

    For iCtr = 1 To lRows * 20 ' 20 vezes o numero de linhas para garantir um bom emabaralhamento.. lNum1 = WorksheetFunction.RandBetween(1, lRows) lNum2 = WorksheetFunction.RandBetween(1, lRows) Temp = Cells(lNum1, lCol) Cells(lNum1, lCol) = Cells(lNum2, lCol) Cells(lNum2, lCol) = Temp Next iCtr

       Next lCol

    End Sub Sub fncMain(lCols As Long, lRows As Long) Const cstrNúmeros As String = "01 02 07 10 12 15 18 22 30 35 46 58 59 64 66 71 74 75 76 78" Dim lRow As Long Dim lRowCount As Long Dim lMax As Long Dim asNúmeros() As String Dim lCol As Long asNúmeros = Split(cstrNúmeros) lMax = UBound(asNúmeros) Cells.Delete lRow = 0 lRowCount = 1 Do For lCol = 1 To lCols Cells(lRowCount, lCol) = asNúmeros(lRow) Next lCol lRowCount = lRowCount + 1 lRow = lRow + 1 If lRow > lMax Then lRow = 0 End If Loop While lRowCount <= lRows End Sub

    Note que ele vai criar uma sequencia aleatoria com todos os elementos definidos no seu array repetindo eles de uma maneira uniforme.. ou seja, no exemplo vc pediu 10000 linhas onde em cada coluna voce vai ter extamente 500 elementos de cada um espaçados de forma aleatoria


    William John Adam Trindade
    Analyste-programmeur
    ----------------------------------------------------------


    segunda-feira, 18 de novembro de 2013 14:45

Todas as Respostas

  • NAo entendi sua duvida.. poderia ser mais claro... o que vc quer alterar?

    Simplesmente o link nao esta funcionando aqui.

    Att


    William John Adam Trindade
    Analyste-programmeur
    ----------------------------------------------------------


    quarta-feira, 13 de novembro de 2013 20:05
  • O link é esse mesmo:

    http://www.sendspace.com/c2488l ___depois do 8 a letra L

    ou

    http://www.sendspace.com/file/4rescg


    Grato

    quarta-feira, 13 de novembro de 2013 23:37
  • Mas qual é a duvida.. o que vc quer alterar? O arquivo no linq é um XLSM?

    Desculpe, mas creio que ninguem vá baixa-lo... O site altem de duvidoso o arquivo contem macros e isso quer dizer potencialmente: VIRUS.

    Caso queria ajuda, poste aqui o conteudo da macro e o que vc quer alterar...

    Att


    William John Adam Trindade
    Analyste-programmeur
    ----------------------------------------------------------


    quinta-feira, 14 de novembro de 2013 13:16
  • Boa tarde

    Não quero parecer arrogante, desrespeitoso ou qualquer outra coisa que o valha. Mas alguma coisa acontece com meus post, sempre usei essa forma de postagem para esclarecer minhas duvidas, solicitações e pedidos de ajuda, coisa que sempre fui atendido com a maior presteza e acerto por parte dessa competente equipe do fórum. Me custa acreditar, que virei alvo de desconfianças e má fé para com aqueles que sempre me auxiliaram nos momentos de precisão. Para evitar mal entendido, desgaste a minha pessoa e desconforto ao fórum, é que peço a exclusão da minha conta.

    Att

    Carlito penna

    quinta-feira, 14 de novembro de 2013 15:50
  • Nao é desconfiança.. simplesmente eu nao estou entendendo sua solicitaçao..

    O arquivo que vc postou, por exemplo, é bloqueado aqui na empresa simplesmente pelo fato de ser um XLSM.. Como o risco é grande o firewall nao permite nenhum tipo de download deste tipo de arquivo.

    Outro detalhe... mesmo que o arquivo seja limpo e eu possa baixa-lo eu nao entendi o que vc quer fazer com ele.. qual é a sua duvida?

    Deixe bem claro de qual forma voce quer "alterar o modo como os parâmetros são informados"

    Att


    William John Adam Trindade
    Analyste-programmeur
    ----------------------------------------------------------

    quinta-feira, 14 de novembro de 2013 16:12
  • Boa tarde

    O que faz a macro original:

     É informada uma sequencia numérica, a quantidade de linhas, colunas e a distancia que deve ficar um numero igual a si próprio. A alteração a mais, seria que a quantidade de números iguais, ficasse equilibrada entre as colunas. Vamos pegar o 07 como exemplo.  Depois de rodada a macro ele apareceria em muitas ocorrências no formato abaixo, nas colunas 1, 2 e 3 com quantidades mais ou menos iguais. Tudo isso obedecendo aos parâmetros da macro original.

    _____Coluna1____Coluna2____Coluna3__

    _______07_________22_________35____

    _______58_________07_________75____

    _______01_________64_________07____

    Ex.:

    Na coluna 1, foram geradas 250 sequencias  em que o 7 apareceu. Na coluna 2, 230 sequencias com o 7. E na coluna 3, foram 240 sequencias com o numero 7.

    O objetivo é equilibrar todos os números informados em quantidades parecidas distribuídos nas colunas, evitando-se que na coluna 1, tenha dez 7, na coluna 2 trezentos 7 e na coluna 3 trinta e cinco 7.

    Reforçando a ideia: Depois de rodada a macro, todos os números informados, aparecem nas colunas, mais ou menos em quantidades iguais.

    Grato

    Sub fncMain()
         Const cstrNúmeros As String = "01 02 07 10 12 15 18 22 30 35 46 58 59 64 66 71 74 75 76 78"
         Dim lRows As Long
         Dim lCols As Long
         Dim lRow As Long
         Dim lCol As Long
         Dim lMin As Long
         Dim lMax As Long
         Dim lDist As Long
         Dim lNum As Long
         Dim bInválido As Boolean
         Dim lVal As Long
         Dim asNúmeros() As String
    
        'Não alterar
         lRows = 10000 'quantidade de linhas
         lCols = 3    'quantidade de colunas
         lDist = 5   'distancia entre números iguais
         
         asNúmeros = Split(cstrNúmeros)
         lMin = LBound(asNúmeros)
         lMax = UBound(asNúmeros)
    
         Cells.Delete
         For lRow = 1 To lRows
             For lCol = 1 To lCols
                 Do
                     bInválido = False
                     lNum = WorksheetFunction.RandBetween(lMin, lMax)
                     lNum = asNúmeros(lNum)
                     For lVal = WorksheetFunction.Max(1, lRow - lDist) To lRow
                         If fncMatch(lNum, Rows(lVal)) > 0 Then
                             bInválido = True
                             Exit For
                         End If
                     Next lVal
                 Loop While bInválido
                 Cells(lRow, lCol) = lNum
             Next lCol
         Next lRow
        End Sub
        
    Function fncMatch(ByVal vTermo As Variant, ByVal vVetor As Variant) As Long
        'Se vVetor for um objeto Range, retorna o número da linha ou coluna
        'de uma célula com conteúdo vTermo numa linha ou coluna.
        'Se vVetor for um vetor, retorna o índice do elemento vTermo no vetor.
        'Caso não seja encontrada nenhuma ocorrência, é retornado 0.
        
        Dim Temp 'As Long
        
        On Error Resume Next
        Temp = WorksheetFunction.Match(CStr(vTermo), vVetor, 0)
        If Temp = 0 Then Temp = WorksheetFunction.Match(vTermo + 0, vVetor, 0)
        On Error GoTo 0
        
        If Temp > 0 Then
            Select Case TypeName(vVetor)
                Case "Range"
                    If vVetor.Columns.Count = 1 Then
                        'vVetor é uma coluna
                        Temp = Temp + vVetor.Row + 1
                    ElseIf vVetor.Rows.Count = 1 Then
                        'vVetor é uma linha
                        Temp = Temp + vVetor.Column - 1
                    End If
            End Select
        End If
        
        fncMatch = Temp
    End Function
    


    quinta-feira, 14 de novembro de 2013 18:31
  • Para o exemplo que vc forneceu, o resultado é esse:

                   N             qtd col1       qtd col2         qtd col3

    1 538 461 489
    2 488 533 468
    7 489 484 530
    10 485 511 513
    12 520 472 492
    15 476 479 545
    18 490 504 512
    22 486 481 532
    30 477 514 506
    35 500 536 467
    46 523 514 468
    58 486 517 507
    59 491 538 472
    64 530 492 480
    66 494 493 511
    71 482 497 521
    74 482 499 511
    75 550 484 470
    76 523 484 500
    78 490 507 506

    Note que eu nao vi nenhuma discrepancia muito grande ( o desvio padrao esta dentro do aceitavel, no pior caso, 75 onde o desvio padrao foi de 32 ocorrencias)

    Se voce quer equilibrar o desvio padrao em uma populaçao aleatoria eu nao vejo muita utilidade para a geraçao aleatoria. Neste caso o que eu faria seria   um processo de duas etapas. Primeiro, criaria a sequencia completa e depois faria uma "reordenaçao" da lista utilizando um algoritmo para embaralhar (scramble)... desta forma vc reduz o desvio padrao de ocorrencias da coluna à zero.

    Att


    William John Adam Trindade
    Analyste-programmeur
    ----------------------------------------------------------



    quinta-feira, 14 de novembro de 2013 19:08
  • Boa noite

    "Neste caso o que eu faria seria   um processo de duas etapas. Primeiro, criaria a sequencia completa e depois faria uma "reordenaçao" da lista utilizando um algoritmo para emaralhar (scramble).

    Certíssimo, esse é o caminho a tomar, só falta desenvolver a solução. Fique a vontade e eu lhe agradeço por esse imenso favor.

    Grato 

    quinta-feira, 14 de novembro de 2013 23:44
  • Minha soluçao é:

    Option Explicit Sub CriarSequenciaAleatoriaUniforme() Dim iCtr As Long Dim lNum1 As Long Dim lNum2 As Long Dim Temp As Variant Dim lRows As Long Dim lCols As Long Dim lCol As Long lRows = 10000 'quantidade de linhas lCols = 3 'quantidade de colunas Call fncMain(lCols, lRows) 'Inicia a planilha     For lCol = 1 To lCols

    For iCtr = 1 To lRows * 20 ' 20 vezes o numero de linhas para garantir um bom emabaralhamento.. lNum1 = WorksheetFunction.RandBetween(1, lRows) lNum2 = WorksheetFunction.RandBetween(1, lRows) Temp = Cells(lNum1, lCol) Cells(lNum1, lCol) = Cells(lNum2, lCol) Cells(lNum2, lCol) = Temp Next iCtr

       Next lCol

    End Sub Sub fncMain(lCols As Long, lRows As Long) Const cstrNúmeros As String = "01 02 07 10 12 15 18 22 30 35 46 58 59 64 66 71 74 75 76 78" Dim lRow As Long Dim lRowCount As Long Dim lMax As Long Dim asNúmeros() As String Dim lCol As Long asNúmeros = Split(cstrNúmeros) lMax = UBound(asNúmeros) Cells.Delete lRow = 0 lRowCount = 1 Do For lCol = 1 To lCols Cells(lRowCount, lCol) = asNúmeros(lRow) Next lCol lRowCount = lRowCount + 1 lRow = lRow + 1 If lRow > lMax Then lRow = 0 End If Loop While lRowCount <= lRows End Sub

    Note que ele vai criar uma sequencia aleatoria com todos os elementos definidos no seu array repetindo eles de uma maneira uniforme.. ou seja, no exemplo vc pediu 10000 linhas onde em cada coluna voce vai ter extamente 500 elementos de cada um espaçados de forma aleatoria


    William John Adam Trindade
    Analyste-programmeur
    ----------------------------------------------------------


    segunda-feira, 18 de novembro de 2013 14:45
  • Boa tarde

    Inicialmente, queria me desculpar pelo mau comportamento no inicio, em relutar para aceitar a sugestão de editar o código diretamente aqui. Genial a maneira como é montada as sequencias, mas notei que em algumas linhas há repetição de numero, mas isso é o de menos. Muito obrigado pela contribuição.

    Abraço.


    • Editado carlito_penna segunda-feira, 18 de novembro de 2013 15:04
    segunda-feira, 18 de novembro de 2013 15:04
  • Sim.. A rotina que eu uso para embaralhar é a mais simples possivel.. Repetiçoes sao possiveis, mas eu nao vejo como evitar elas totalmente.. Em algum momento vai repetir.

    O que vc precisa é evitar a reptiçao tanto em linhas como em colunas?

    Digo, usandp seu exemplo do "7", este tipo de coisa nao poderia ocorrer:

    7 7 7

    7 x x

    7 x x

    ?

    Para isso teria que haver uma outra rotina de harmonizaçao... mas dependendo o que vc quer fazer vai estragar a aleatoriedade tambem.

    Att


    William John Adam Trindade
    Analyste-programmeur
    ----------------------------------------------------------

    segunda-feira, 18 de novembro de 2013 15:31
  • Boa tarde

    De fato ia precisar de outra rotina, mas a solução desenvolvida é suficiente para resolver 99% de minha necessidade. 

    Grato

    segunda-feira, 18 de novembro de 2013 16:54