Incrementada em código

Question

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

Answer 1

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

Sogi Informatique ltée

Answer 2

O link é esse mesmo:

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

ou

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

Grato

Answer 3

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

Sogi Informatique ltée

Answer 4

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

Answer 5

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

Sogi Informatique ltée

Answer 6

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

Answer 7

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

Sogi Informatique ltée

Answer 8

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 

Answer 9

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

Sogi Informatique ltée

Answer 10

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.

Answer 11

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

Sogi Informatique ltée

Answer 12

Boa tarde

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

Grato