Usuário com melhor resposta
Incrementada em código

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
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
----------------------------------------------------------
- Editado William John Adam Trindade segunda-feira, 18 de novembro de 2013 14:46
- Marcado como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 7 de junho de 2014 19:11
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
----------------------------------------------------------
- Editado William John Adam Trindade quarta-feira, 13 de novembro de 2013 20:06
- Sugerido como Resposta William John Adam Trindade segunda-feira, 18 de novembro de 2013 15:46
-
-
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
----------------------------------------------------------
- Editado William John Adam Trindade quinta-feira, 14 de novembro de 2013 13:20
-
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
-
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
----------------------------------------------------------
-
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
-
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
----------------------------------------------------------
- Editado William John Adam Trindade segunda-feira, 18 de novembro de 2013 21:59
-
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
-
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
----------------------------------------------------------
- Editado William John Adam Trindade segunda-feira, 18 de novembro de 2013 14:46
- Marcado como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 7 de junho de 2014 19:11
-
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
-
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
----------------------------------------------------------
-