VBA per caratteri random

[marcopont]

Ciao a tutti

avrei bisogno del vostro aiuto per scrivere se possibile un codice che faccia questo:

se in una cella (es: a1) c'e' il carattere "X" allora sulla riga corrispondente deve scrivere per 3 volte, in 3 celle random, il carattere "X"
la funzione dovra' ripetersi per tutta la lunghezza dell'elenco e le celle dove dovra' scrivere devono essere sempre casuali.


grazie in anticipo per l'attenzione e il tempo che vorrete dedicarmi.

Marco

[Marius44]

Ciao
Occorrono due cose, a mio parere,
a) un tuo file con le prove che hai fatto
b) maggiori info circa le celle "casuali" sulla stessa riga:
1) fino a quale cella?
2) per tutto l'elenco quale?

Ciao,
Mario

[marcopont]

ciao e grazie

non riesco ad allegare il file
in sostanza e' un elenco di 180 righe che riportano:
colonna A nome
colonna B cognome
colonna C Lavorativo
da colonna D a colonna AH i giorni del mese

in sostanza se nella colonna C si legge un "x" allora nella riga dell'utente corrispondente deve scrivere in 3 celle random 3 "X"

non ho idea su come fare

[Marius44]

Ciao
Prova se è quello che volevi.
Mi spiego:
in D1 occorre inserire una data (gg/mm/aa) - ti apparirà solo il mese
in D2 inserisci questa formula =DATA(ANNO(D1);MESE(D1);1)
in E2 inserisci questa formula =SE(MESE(D2+1)=MESE($D$1);D2+1;"") - da copiare a destra fino a AE2
in AF2 inserisci questa formula =SE(AE2<>"";SE(MESE(AE2+1)=MESE($D$1);AE2+1;"");"") - da copia re a destra fino a AH2
Poi necessita questo codice da inserire nel Modulo del Foglio interessato

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
  ur = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 1 To 35
    If Cells(2, i) = "" Then uc = i: Exit For
  Next i
  If Not Intersect(Target, Range("C3:C183")) Is Nothing Then
    If UCase(Cells(Target.Row, 3)) = "X" Then
      Range("D" & Target.Row & ":AH" & Target.Row).ClearContents
      For j = 1 To 3
        Randomize
        c = Application.WorksheetFunction.RandBetween(4, uc)
        Cells(Target.Row, c) = "X"
      Next j
    ElseIf Cells(Target.Row, 3) = "" Then
      Range("D" & Target.Row & ":AH" & Target.Row).ClearContents
    End If
  End If
End Sub


Allego il file link
https://www.dropbox.com/s/c98mj7tw6xiv39m/ICS.xlsm?dl=0
Ciao,
Mario

[marcopont]

Grazie Mario

top

[Anthony47]

Attenzione che la macro potrebbe impostarti talvolta solo 2 X, raramente anche solo 1 e magari "fuori mese"; inoltre funziona solo se si modifica una cella alla volta (non se ad es. si cancellano N celle)
Senza variarne l'approccio, suggerirei quindi di modificarla in questo modo:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
ur = Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To 35
    If Cells(2, i) = "" Then uc = i - 1: Exit For
Next i
Dim myC As Range
Randomize
Application.EnableEvents = False
For Each myC In Target
  If Not Intersect(myC, Range("C3:C183")) Is Nothing Then
    If UCase(Cells(myC.Row, 3)) = "X" Then
      Range("D" & myC.Row & ":AH" & myC.Row).ClearContents
      For j = 1 To 3
        c = Application.WorksheetFunction.RandBetween(4, uc)
        If Cells(myC.Row, c) = "" Then
            Cells(myC.Row, c) = "X"
        Else
            j = j - 1
        End If
      Next j
    ElseIf Cells(myC.Row, 3) = "" Then
      Range("D" & myC.Row & ":AH" & myC.Row).ClearContents
    End If
  End If
Next myC
Application.EnableEvents = True
End Sub


Le modifiche riguardano il calcolo di uc, l'esame di ognuna delle cella in Target e la verifica che la cella obiettivo sia ancora vuota.

Ciao a tutti

[Marius44]

Ecco perchè esistono due categorie di persone:
i professori (o meglio, Professoroni)
gli scolaretti.

Grazie Anthony.
Comunque son contento perchè, in un certo qual modo, ho azzeccato il procedimento.
Ciao,
Mario

[Anthony47]

Mario, che fai, prendi per i fondelli?

[Marius44]

Assolutamente NO.
Dico solo la verità.

Ciao,
Mario

[marcopont]

ciao Anthony e grazie

ho provato la tua soluzione e ovviamente funziona.
Ora sto provando ad applicarla su un altro file con i dati pero' spostati in altre colonne (mi pareva semplice ma non capisco dove sbaglio)
I nuovi dati sono in colonna G2:G183 (la colonna dove deve fare il check per la presenza della "x")
mentre le colonne dove scrivere la x random se il check e' positivo sono H2:AL183.

ho cambiato cosi' il tuo codice ma non va:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
ur = Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To 35
    If Cells(2, i) = "" Then uc = i - 1: Exit For
Next i
Dim myC As Range
Randomize
Application.EnableEvents = False
For Each myC In Target
  If Not Intersect(myC, Range("g3:g183")) Is Nothing Then
    If UCase(Cells(myC.Row, 3)) = "X" Then
      Range("H" & myC.Row & ":AL" & myC.Row).ClearContents
      For j = 1 To 3
        c = Application.WorksheetFunction.RandBetween(4, uc)
        If Cells(myC.Row, c) = "" Then
            Cells(myC.Row, c) = "X"
        Else
            j = j - 1
        End If
      Next j
    ElseIf Cells(myC.Row, 3) = "" Then
      Range("H" & myC.Row & ":AL" & myC.Row).ClearContents
    End If
  End If
Next myC
Application.EnableEvents = True
End Sub

dove sbaglio per piacere?

Grazie, Marco

[Anthony47]

La versione allineata ai nuovi parametri:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
ur = Cells(Rows.Count, 1).End(xlUp).Row
For i = 8 To 40                                             '**Da colonna H
    If Cells(2, i) = "" Then uc = i - 1: Exit For
Next i
Dim myC As Range
Randomize
Application.EnableEvents = False
For Each myC In Target
  If Not Intersect(myC, Range("g3:g183")) Is Nothing Then
    If UCase(Cells(myC.Row, "G")) = "X" Then                    '**
      Range("H" & myC.Row & ":AL" & myC.Row).ClearContents
      For j = 1 To 3
        c = Application.WorksheetFunction.RandBetween(8, uc)    '**
        If Cells(myC.Row, c) = "" Then
            Cells(myC.Row, c) = "X"
        Else
            j = j - 1
        End If
      Next j
    ElseIf Cells(myC.Row, "G") = "" Then                        '**
      Range("H" & myC.Row & ":AL" & myC.Row).ClearContents
    End If
  End If
Next myC
Application.EnableEvents = True
End Sub


Sono intervenuto sulle righe marcate **

Questa invece e' una versione "parametrizzata", dove i parametri corrispondono alle righe marcate <<<

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
Dim hCols As String, UC As Long, xCol As String
Dim myC As Range, UR As Long, nCol As String
'
hCols = "H2:AL2"        '<<< L'area sotto cui inserire le 3 X
xCol = "B"              '<<< La colonna dove si imposta la X
nCol = "A"              '<<< La colonna con i nominativi
'
For Each myC In Range(hCols)
    If myC.Value = "" Then UC = myC.Column - 1: Exit For
Next myC
If UC = 0 Then
    UC = Range(hCols).Cells(1, 1).Column + Range(hCols).Columns.Count - 1
End If
UR = Cells(Rows.Count, nCol).End(xlUp).Row
Randomize
Application.EnableEvents = False
For Each myC In Target
    If Not Intersect(myC, Cells(3, xCol).Resize(UR, 1)) Is Nothing Then
        If UCase(Cells(myC.Row, xCol)) = "X" Then
            Range(hCols).Offset(myC.Row - Range(hCols).Cells(1, 1).Row, 0).ClearContents
            For j = 1 To 3
                c = Application.WorksheetFunction.RandBetween(Range(hCols).Cells(1, 1).Column, UC)
                If Cells(myC.Row, c) = "" Then
                    Cells(myC.Row, c) = "X"
                Else
                    j = j - 1
                End If
            Next j
        ElseIf Cells(myC.Row, xCol) = "" Then
            Range(hCols).Offset(myC.Row - Range(hCols).Cells(1, 1).Row, 0).ClearContents
        End If
    End If
Next myC
Application.EnableEvents = True
End Sub


Ciao