MaximoAccess

Caro Usuário, não tire as suas duvidas nas Salas de Repositório, abra sempre um novo tópico relacionado, nas salas destinadas para o efeito, como Sala de Tabelas, Consultas, Formulários, Relatórios, Macros, Módulos e VBA.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Ajuste Codigo

    Compartilhe

    ssvp
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 30
    Registrado : 15/01/2013

    Ajuste Codigo

    Mensagem  ssvp em Qui 09 Jun 2016, 14:22

    Este é um sistema de sorteio de bingo e verifiquei que nao esta correto a geracao de cartelas. Seria possível alguem verificar este codigo e verificar o seguinte: as pedras de 1 a 20 devem sair para a coluna B, de 21 a 40 para coluna I, de 41 a 60 para acoluna N, de 61 a 80 para coluna G e de 81 a 100 na coluna O.

    Como nao conheco de programacao , penso que o problema pode estar no codigo a seguir, porem nao consigo corrigí-lo.

    José Silvio

    ssvp
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 30
    Registrado : 15/01/2013

    Esqueci de colar o codigo, desculpem

    Mensagem  ssvp em Qui 09 Jun 2016, 14:45

    Sub FillCardsSTD(lngCardCount As Long, Optional blnFreeSpace As Boolean = False)

    On Error GoTo Err_FillCards_Click

    Dim myDB As Database
    Dim rsCards As Recordset
    Dim intCellCounter As Integer
    Dim lngCardCounter As Long
    Dim fldCurrentField As Field

    Set myDB = CurrentDb()
    Set rsCards = myDB.OpenRecordset("tblCards", dbOpenDynaset)
    '---Main

    'clear cards table
    DoCmd.SetWarnings False
    DoCmd.OpenQuery "qrdClearCards"
    DoCmd.SetWarnings True

    'Set up outer loop to iterate the once for each card specified in txtNumCards
    For lngCardCounter = 1 To lngCardCount
    rsCards.AddNew
    rsCards!cardno = lngCardCounter
    'setup inner loop to iterate across the current record and fill with selected values
    Set fldCurrentField = rsCards.Fields(0) 'cell 0 = cardno and is the card sequence number
    fldCurrentField.Value = lngCardCounter
    For intCellCounter = 1 To 25 'the rest of the cells
    Set fldCurrentField = rsCards.Fields(intCellCounter)
    Select Case intCellCounter
    Case 1, 6, 11, 16, 21 'the B column
    fldCurrentField.Value = FindRandom_TSB("", "tblB", "CellContents")
    Case 2, 7, 12, 17, 22 'the I column
    fldCurrentField.Value = FindRandom_TSB("", "tblI", "CellContents")
    Case 3, 8, 13, 18, 23 'the N column
    If Not intCellCounter = 13 Then
    fldCurrentField.Value = FindRandom_TSB("", "tblN", "CellContents")
    ElseIf blnFreeSpace Then
    fldCurrentField.Value = "AtivoAccess"
    Else
    fldCurrentField.Value = FindRandom_TSB("", "tblN", "CellContents")
    End If
    Case 4, 9, 14, 19, 24 'the G column
    fldCurrentField.Value = FindRandom_TSB("", "tblG", "CellContents")
    Case 5, 10, 15, 20, 25 'the O column
    fldCurrentField.Value = FindRandom_TSB("", "tblO", "CellContents")
    Case Else
    End Select
    Next 'Card field
    'save/commit new record before moving to next row
    rsCards.Update
    'clear used flags in Cell Contents table
    DoCmd.SetWarnings False
    DoCmd.OpenQuery "qruSetUsedtoFalseB"
    DoCmd.OpenQuery "qruSetUsedtoFalseI"
    DoCmd.OpenQuery "qruSetUsedtoFalseN"
    DoCmd.OpenQuery "qruSetUsedtoFalseG"
    DoCmd.OpenQuery "qruSetUsedtoFalseO"
    DoCmd.SetWarnings True
    Next 'Card record
    '---Clean up
    Set rsCards = Nothing
    Set myDB = Nothing

    Exit_FillCards_Click:
    Exit Sub

    Err_FillCards_Click:
    MsgBox Err.Description
    Resume Exit_FillCards_Click

    End Sub

      Data/hora atual: Sex 09 Dez 2016, 07:40