› Excel e gli applicativi Microsoft Office › Scrivere soluzione con carattere rosso e sfondo giallo.
-
AutoreArticoli
-
Buonasera a tutti. Ho un file Office 2003 che mi risolve il gioco del sudoku. C'è il pulsante dove sta assegnata la macro che una volta cliccata funziona perfettamente. Solo che vorrei che mi scrivesse la soluzione con il colore del carattere rosso e lo sfondo giallo. Quale riga di codice e dove la devo aggiungere? Spero di essere stato chiaro. Non ho la possibilità di postare il codice altrimenti lo avrei già fatto. Grazie in anticipo
Le informazioni che dai sono insufficenti per poterti dare un'aiuto prova a creare un piccolo esempio e postarlo
Cerca sull'help
interior
font
e relativi proprietà e metodi
Ciao
Luca
`Dim Schema As Worksheet Dim Mosse As Worksheet Dim RStart As Integer Dim CStart As Integer Dim SMossa As Integer Dim MosseFatte As Integer 'Dim Mossa As Integer Sub genera_set_iniziale() Dim i As Integer, j As Integer Dim l As Integer, c As Integer Dim RigaAppartenenza As Integer Dim ColAppartenenza As Integer Dim QuadratinoAppartenenza As Integer Dim Valore As Integer Dim pos As Integer For i = 1 To 81 Mosse.Cells(i, 1).Value = "No" Mosse.Cells(i, 2).Value = 9 For j = 1 To 9 Mosse.Cells(i, j + 2).Value = j Next Next For l = 1 To 9 For c = 1 To 9 If Schema.Cells(l + RStart, c + CStart).Value <> "" Then ' c'é un numero nello schema inziale, ' eliminiamo tutto ciò che non è compatibile RigaAppartenenza = l ColAppartenenza = c QuadratinoAppartenenza = (l - 1) \ 3 + ((c - 1) \ 3) * 3 + 1 Valore = Schema.Cells(l + RStart, c + CStart).Value 'abbiamo identificato le coordinate da cui eliminare 'schema.Cells(l + RStart, c + CStart) = QuadratinoAppartenenza 'elininazione tutte le altre possibilità sulla posizione della mossa pos = CRiga(RigaAppartenenza, ColAppartenenza, 0) For i = 1 To 9 If Mosse.Cells(pos, i + 2) <> Valore Then Mosse.Cells(pos, i + 2) = "X" Mosse.Cells(pos, 1) = "Si" Mosse.Cells(pos, 2) = 1 Next 'eliminazione righe For i = 1 To 9 pos = CRiga(i, ColAppartenenza, 0) If Mosse.Cells(pos, 1) <> "Si" Then If Mosse.Cells(pos, Valore + 2).Value = Valore Then Mosse.Cells(pos, 2).Value = Mosse.Cells(pos, 2).Value - 1 End If Mosse.Cells(pos, Valore + 2).Value = "X" End If Next 'eliminazione colonne For i = 1 To 9 pos = CRiga(RigaAppartenenza, i, 0) If Mosse.Cells(pos, 1) <> "Si" Then If Mosse.Cells(pos, Valore + 2).Value = Valore Then Mosse.Cells(pos, 2).Value = Mosse.Cells(pos, 2).Value - 1 End If Mosse.Cells(pos, Valore + 2).Value = "X" End If Next 'eliminazione blocchetto 3x3 For i = 1 To 9 For j = 1 To 9 pos = CRiga(j, i, 0) If (j - 1) \ 3 + ((i - 1) \ 3) * 3 + 1 = QuadratinoAppartenenza Then If Mosse.Cells(pos, 1) <> "Si" Then If Mosse.Cells(pos, Valore + 2).Value = Valore Then Mosse.Cells(pos, 2).Value = Mosse.Cells(pos, 2).Value - 1 End If Mosse.Cells(pos, Valore + 2).Value = "X" End If End If Next Next End If Next Next End Sub Private Function CRiga(riga As Integer, colonna As Integer, Mossa As Integer) As Integer CRiga = Mossa * SMossa + riga * 9 + colonna - 9 End Function Function TrovaSoluzione(OMossa As Integer) As Boolean Dim i As Integer Dim j As Integer Dim minimo As Integer Dim iminimo As Integer Dim jminimo As Integer Dim k As Integer Dim pos As Integer Dim Successo As Boolean Dim Mossa As Integer Dim QuadratinoAppartenenza As Integer Dim scelta As Integer Dim Valore As Integer Dim TuttoMosso As Boolean Mossa = OMossa + 1 MosseFatte = MosseFatte + 1 'copia tutto un pezzo più in basso For i = 1 To 81 For j = 1 To 11 Mosse.Cells(Mossa * SMossa + i, j).Value = Mosse.Cells(OMossa * SMossa + i, j).Value Next Next TuttoMosso = True minimo = 99 Successo = False For i = 1 To 9 For j = 1 To 9 pos = CRiga(i, j, Mossa) If Mosse.Cells(pos, 2).Value < minimo And Mosse.Cells(pos, 1).Value <> "Si" Then minimo = Mosse.Cells(pos, 2).Value iminimo = i jminimo = j QuadratinoAppartenenza = (i - 1) \ 3 + ((j - 1) \ 3) * 3 + 1 End If If Mosse.Cells(CRiga(i, j, Mossa), 1) <> "Si" Then TuttoMosso = False Next Next k = 1 scelta = 0 If Not TuttoMosso Then While Not Successo And k <= minimo 'facciamo la mossa: il primo valore buono alla colonna iminimo,jminimo pos = CRiga(iminimo, jminimo, Mossa) scelta = scelta + 1 'trovo il valore da mettere While Mosse.Cells(pos, scelta + 2).Value = "X" scelta = scelta + 1 Wend 'metto il valore Valore = Mosse.Cells(pos, scelta + 2).Value Schema.Cells(iminimo + RStart, jminimo + CStart).Value = Valore ' pulisco le mosse non più permesse For i = 1 To 9 If Mosse.Cells(pos, i + 2) <> Valore Then Mosse.Cells(pos, i + 2) = "X" Mosse.Cells(pos, 1) = "Si" Mosse.Cells(pos, 2) = 1 Next 'eliminazione righe For i = 1 To 9 pos = CRiga(i, jminimo, Mossa) If Mosse.Cells(pos, 1) <> "Si" Then If Mosse.Cells(pos, Valore + 2).Value = Valore Then Mosse.Cells(pos, 2).Value = Mosse.Cells(pos, 2).Value - 1 End If Mosse.Cells(pos, Valore + 2).Value = "X" End If Next 'eliminazione colonne For i = 1 To 9 pos = CRiga(iminimo, i, Mossa) If Mosse.Cells(pos, 1) <> "Si" Then If Mosse.Cells(pos, Valore + 2).Value = Valore Then Mosse.Cells(pos, 2).Value = Mosse.Cells(pos, 2).Value - 1 End If Mosse.Cells(pos, Valore + 2).Value = "X" End If Next 'eliminazione blocchetto 3x3 For i = 1 To 9 For j = 1 To 9 pos = CRiga(j, i, Mossa) If (j - 1) \ 3 + ((i - 1) \ 3) * 3 + 1 = QuadratinoAppartenenza Then If Mosse.Cells(pos, 1) <> "Si" Then If Mosse.Cells(pos, Valore + 2).Value = Valore Then Mosse.Cells(pos, 2).Value = Mosse.Cells(pos, 2).Value - 1 End If Mosse.Cells(pos, Valore + 2).Value = "X" End If End If Next Next Successo = TrovaSoluzione(Mossa) If Not Successo Then Schema.Cells(iminimo + RStart, jminimo + CStart).Value = "" 'rimetto a posto l'elenco delle mosse prima della mossa fatta errata For i = 1 To 81 For j = 1 To 11 Mosse.Cells(Mossa * SMossa + i, j).Value = Mosse.Cells(OMossa * SMossa + i, j).Value Next Next End If k = k + 1 Wend End If If TuttoMosso = True Then TrovaSoluzione = TuttoMosso Else TrovaSoluzione = Successo End If End Function Sub genera_inizio() Dim Mossa As Integer Dim Successo As Boolean Set Schema = Worksheets("Schema") Set Mosse = Worksheets("Mosse") RStart = 3 CStart = 2 SMossa = 83 Mossa = 0 Schema.Cells(18, 5).Value = "" MosseFatte = 0 Call genera_set_iniziale Successo = TrovaSoluzione(Mossa) If Successo Then Schema.Cells(18, 5).Value = "Risolto in " & MosseFatte & " mosse" Else Schema.Cells(18, 5).Value = "Non risolvibile" End If End Sub `
Sono riuscito a postare tutto il codice VBA.
Dove e cosa devo inserire per avere quello che ho chiesto?
Se ho capito:
sostituisci la Sub genera_inizio() con il codice che ti posto
Sub genera_inizio() Dim Mossa As Integer Dim Successo As Boolean Set Schema = Worksheets("Schema") Set Mosse = Worksheets("Mosse") RStart = 3 CStart = 2 SMossa = 83 Mossa = 0 Schema.Cells(18, 5).Value = "" MosseFatte = 0 Call genera_set_iniziale Successo = TrovaSoluzione(Mossa) If Successo Then Schema.Cells(18, 5).Value = "Risolto in " & MosseFatte & " mosse" Schema.Cells(18, 5).Interior.ColorIndex = xlNone Schema.Cells(18, 5).Interior.ColorIndex = 6 Schema.Cells(18, 5).Font.Color = 3 Schema.Cells(18, 5).Font.Color = RGB(255, 0, 0) Else Schema.Cells(18, 5).Value = "Non risolvibile" Schema.Cells(18, 5).Interior.ColorIndex = xlNone Schema.Cells(18, 5).Interior.ColorIndex = 6 Schema.Cells(18, 5).Font.Color = RGB(255, 0, 0) End If End Sub
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )#albatros54
Ho provato la tua soluzione ma non va; non mi colore di rosso e sfondo giallo la soluzione ein più va in debug nelle righe di codice che hai inserito.
Ho allegato l'immagine del file.
ciao Antonio
penso che per trovare la soluzione bisognerebbe avere il file a disposizione, perche ricostruirlo exnovo in base alle sub() e' un lavoraccio,
quindi sempre se e' possibile mettere in rete tale file con le sub() inserite e i suoi fogli inerenti
ciao
PS metti anche alcune spiegazioni da come bisogna fare per attuare il tutto, ess. inserimento dati da un sudoku che troviamo sul giornale e da li sviluppare, o altre formule di sviluppo
#Mister_x
Stavo provando a mettere il file in rete ma si potevo inserire solo file immagini. Comunque il file è semplicissimo:
le celle vanno dalla C4:K12
poi c'è il pulsante dove sta assegnata la macro con il codice che ho postato e che funziona perfettamente.
Faccio un un'esempio pratico:
nell'intervallo C4:K12 scrivo il sudoku da risolvere, dopo clicco sul pulsante "risolvi" e me lo risolve, solo che vorrei che me lo scrivesse con il colore rosso e lo sfondo giallo.
ciao Antonio
per inserire un file basta andare su scegli un file , e ti viene proposta una scermata dove a destra trovi ( tutti i file (*.*) e a sinistra devi selezionare la cartella dove si trova il tuo file PS il file da caricare deve essere chiuso
Comunque visto da VBA i fogli in questione sono 2 , immagino che uno e' nascosto
Set Schema = Worksheets("Schema")
Set Mosse = Worksheets("Mosse") Nascosto
ciao
Ho provato la tua soluzione ma non va
ti posto un video con il codice che ti ho postato funzionante, sempre se ho capito
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Allegati:
You must be logged in to view attached files.a me "scegli un file" non c'è.
Il file da ricostruire è semplicissimo soprattutto per voi che siete esperti.
L'immagine che ho allegato fa vedere che le solo celle interessate vanno dalla C4:K12, basta aprire un nuovo file excel copiare il codice va che ho postato e inserire un pulsante per assegnare la macro
#albatros54
Le celle che mi deve fare lo sfondo giallo e il colore rosso sono quelle nell'intervallo "C4:K12" della soluzione del sudoku.
Esempio: io inserisco il sudoku da risolvere nell'intervallo "C4:K12" con il carattere nero e senza sfondo, quando clicco su risolvi mi inserisce i numeri mancanti in quell'intervallo sempre con il carattere nero e senza sfondo mentre io voglio che me li inserisca con lo sfondo giallo e il carattere rosso
ciao Antonio
non serve nessun codice per fare quello che tu dici
Comunque ho ricostruito il tuo file in 20minuti e ti dico che i fogli sono 2 , uno e' nascosto
ti passo il mio file che ho costruito in base alle sub() inserite , e ne ho inserita una di pulizia delle celle
per inserire antri dati de un nuovo rompicapo
PS troverai gia' inserito un sudoku da elaborare per vedere se questo e' quello che vuoi
ciao
Allegati:
You must be logged in to view attached files.Allora:Tu vorresti che ,una volta inseriti dei numeri nello schemma del sudoku da parte tua, i numeri che poi inserisce la tua Routine , ebbano essere inseriti evidenziando la cella e il carattere con i colori da te indicati.
Ho preso il file di Mistre-X è mi sono permesso di aggiungere alcune righe di codice che fanno quello che tu chiedi, sempre se ho capito.
Ti allego il file provalo e fai sapere, anche in formato Excel2003
PS:posto solo la routine dove ho apportato le modifiche
Function TrovaSoluzione(OMossa As Integer) As Boolean Dim i As Integer Dim j As Integer Dim minimo As Integer Dim iminimo As Integer Dim jminimo As Integer Dim k As Integer Dim pos As Integer Dim Successo As Boolean Dim Mossa As Integer Dim QuadratinoAppartenenza As Integer Dim scelta As Integer Dim Valore As Integer Dim TuttoMosso As Boolean Mossa = OMossa + 1 MosseFatte = MosseFatte + 1 'copia tutto un pezzo più in basso For i = 1 To 81 For j = 1 To 11 Mosse.Cells(Mossa * SMossa + i, j).Value = Mosse.Cells(OMossa * SMossa + i, j).Value Next Next TuttoMosso = True minimo = 99 Successo = False For i = 1 To 9 For j = 1 To 9 pos = CRiga(i, j, Mossa) If Mosse.Cells(pos, 2).Value < minimo And Mosse.Cells(pos, 1).Value <> "Si" Then minimo = Mosse.Cells(pos, 2).Value iminimo = i jminimo = j QuadratinoAppartenenza = (i - 1) \ 3 + ((j - 1) \ 3) * 3 + 1 End If If Mosse.Cells(CRiga(i, j, Mossa), 1) <> "Si" Then TuttoMosso = False Next Next k = 1 scelta = 0 If Not TuttoMosso Then While Not Successo And k <= minimo 'facciamo la mossa: il primo valore buono alla colonna iminimo,jminimo pos = CRiga(iminimo, jminimo, Mossa) scelta = scelta + 1 'trovo il valore da mettere While Mosse.Cells(pos, scelta + 2).Value = "X" scelta = scelta + 1 Wend 'metto il valore Valore = Mosse.Cells(pos, scelta + 2).Value Schema.Cells(iminimo + RStart, jminimo + CStart).Value = Valore Schema.Cells(iminimo + RStart, jminimo + CStart).Interior.ColorIndex = 6 '<<<<<<<<< 'Schema.Cells(iminimo + RStart, jminimo + CStart).Font.Color = 3 Schema.Cells(iminimo + RStart, jminimo + CStart).Font.Color = RGB(255, 0, 0)'<<<<<<<<<<< ' pulisco le mosse non più permesse For i = 1 To 9 If Mosse.Cells(pos, i + 2) <> Valore Then Mosse.Cells(pos, i + 2) = "X" Mosse.Cells(pos, 1) = "Si" Mosse.Cells(pos, 2) = 1 Next 'eliminazione righe For i = 1 To 9 pos = CRiga(i, jminimo, Mossa) If Mosse.Cells(pos, 1) <> "Si" Then If Mosse.Cells(pos, Valore + 2).Value = Valore Then Mosse.Cells(pos, 2).Value = Mosse.Cells(pos, 2).Value - 1 End If Mosse.Cells(pos, Valore + 2).Value = "X" End If Next 'eliminazione colonne For i = 1 To 9 pos = CRiga(iminimo, i, Mossa) If Mosse.Cells(pos, 1) <> "Si" Then If Mosse.Cells(pos, Valore + 2).Value = Valore Then Mosse.Cells(pos, 2).Value = Mosse.Cells(pos, 2).Value - 1 End If Mosse.Cells(pos, Valore + 2).Value = "X" End If Next 'eliminazione blocchetto 3x3 For i = 1 To 9 For j = 1 To 9 pos = CRiga(j, i, Mossa) If (j - 1) \ 3 + ((i - 1) \ 3) * 3 + 1 = QuadratinoAppartenenza Then If Mosse.Cells(pos, 1) <> "Si" Then If Mosse.Cells(pos, Valore + 2).Value = Valore Then Mosse.Cells(pos, 2).Value = Mosse.Cells(pos, 2).Value - 1 End If Mosse.Cells(pos, Valore + 2).Value = "X" End If End If Next Next Successo = TrovaSoluzione(Mossa) If Not Successo Then Schema.Cells(iminimo + RStart, jminimo + CStart).Value = "" 'rimetto a posto l'elenco delle mosse prima della mossa fatta errata For i = 1 To 81 For j = 1 To 11 Mosse.Cells(Mossa * SMossa + i, j).Value = Mosse.Cells(OMossa * SMossa + i, j).Value Next Next End If k = k + 1 Wend End If If TuttoMosso = True Then TrovaSoluzione = TuttoMosso Else TrovaSoluzione = Successo End If End Function
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Allegati:
You must be logged in to view attached files.ciao
ciao Albatros, se antonio avesse messo il file la cosa sarebbe stata risolvibile in un battibaleno,
comunque posto il mio parere per l'utilizzo di questo file??? domanda cosa serve nel suo intento ????
il sudoku e' stato ideato per far lavorare la mente , ma se noi ci affidiamo a degli agoritmi il nostro cervello si ATROFIZZA piatto
comunque tanto tempo fa , parlo di minimo 7 anni , era stato elaborato un bel file per il Sudoku , il quale non elaborava le mosse o le probabilita' ( PS lo cerchero' nel mio archivio ) ma si limitava a eliminare dei valori possibili che si potevano inserire nelle varie celle, ma stava a te calcolare se era vero o falso la posizione di tale valore, Praticamente ti aiutava solo a tenere in considerazione i valori possibili che potevi inserire senza tutte le volte ripassare la lettura
detto questo porgo a tutti un bel saluto Ciao
Buongiorno. Il file di Mister_x non fa quello che chiedo mentre il file Sudoku-con-Macro_Albatros54-2003.xls va bene solo che ho copiato l'intero codice nel mio file ma mi da un errore. Ho allegato il mio file
Allegati:
You must be logged in to view attached files.Ciao
Per @toti
All'inizio bisogna azzerare gli eventuali dati precedenti e, con l'occasione, si pongono tutte le celle col Font in nero e grassetto. L' .Interior.ColorIndex è in bianco.
Poi inserisci i dati che vuoi: saranno tutti in nero e sfondo bianco.
Quindi clicchi sul pulsante Risolvi. Innanzi tutto il codice deve scansionare lo schema e se trova un numero scritto lascia lo sfondo in bianco mentre se la cella è vuota imposta il .Font in rosso e l' .InteriorColorIndex in giallo.
Finito. Non ti allego il file perchè, come ha detto Mister X (che saluto) è meglio far lavorare i neuroni.
Ciao,
Mario
solo che ho copiato l'intero codice nel mio file ma mi da un errore. Ho allegato il mio file
Non va bene, ho scaricato il file che hai postato, ma nel codice non ho visto le modifiche che ho apportato e che ti ho postato nel post precedente, controlla bene e non dare risposte avventate!!!!</p
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Scusa la mia ignoranza ma se io copio l'intero codice del tuo file per excel 2003 che funziona nel mio file non dovrebbe funzionare ugualmente dato che l'intervallo delle celle interessate è uguale e cioè C4:K12? Avete aggiunto solo "azzera sudoku".
-
AutoreArticoli