Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

Excel - Modfica macro di Flash30005

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Re: Excel - Modfica macro di Flash30005

Postdi Flash30005 » 25/09/12 22:38

Ho capito solo che se deve accodare due turni visualizza due messaggi ma accoda un turno solo
Ho corretto il bug che risolve questo quesito e i turni verranno accodati nelle righe a seguire (sotto i collaboratori)
a meno che... (*)
Codice: Seleziona tutto
Sub PrgTurni()
NomeF = ActiveSheet.Name
Set Ws1 = Worksheets(NomeF)
UCT = Ws1.Range("IV2").End(xlToLeft).Column
URT = Ws1.Range("A54").End(xlUp).Row
For RRT = 24 To URT
RigaC = RRT
If UCase(Mid(Ws1.Range("A" & RRT).Value, 1, 4)) <> "COLL" Or UCase(Right(Ws1.Range("A" & RRT).Value, 1)) = "X" Then Exit For
Next RRT
NC = RigaC - 23
Rep = ""
Ws1.Range("B14:O53").Interior.ColorIndex = xlNone
        For RRT = 14 To 53
            For CCT = 2 To UCT
                If UCase(Ws1.Cells(RRT, CCT).Value) <> "NO" Then
                Ws1.Cells(RRT, CCT).ClearContents
                End If
            Next CCT
        Next RRT
For ColT = 2 To UCT
MSS = 0
Turno = "10-15"
Contaex = 0
If ColT Mod 2 = 1 Then Turno = "15-20"
For RRL = 5 To 9
Select Case RRL
Case 5
Colore = 6
Rep = "A"
Case 6
Colore = 50
Rep = "B"
Case 7
Colore = 41
Rep = "C"
Case 8
Colore = 15
Rep = "D"
Case 9
Colore = 8
Rep = "E"
End Select
NumP = Ws1.Cells(RRL, ColT).Value
    For RT = 1 To NumP
        If RT = 1 Then
            If Ws1.Cells(RRL + 9, ColT).Value = "" Then
                Ws1.Cells(RRL + 9, ColT).Value = Turno & Rep
                Ws1.Cells(RRL + 9, ColT).Interior.ColorIndex = Colore
            Else
                Ws1.Cells(RRL + 14, ColT).Value = Turno & Rep
                Ws1.Cells(RRL + 14, ColT).Interior.ColorIndex = Colore
            End If
        Else
            MyCNo = 0
            For RRC = 24 To RigaC
                If UCase(Cells(RRC, ColT).Value) = "NO" Then
                    MyCNo = MyCNo + 1
                End If
            Next RRC
            ST = 0
            For RRT = 5 To 9
                ST = ST + Cells(RRT, ColT).Value
            Next RRT
            If NC - MyCNo <= ST - 5 Then
RiprEx:

                If NC - MyCNo < ST - 5 Then
                    If Contaex >= NC - MyCNo Then
                    AggG = "eriggio"
                    If Ws1.Cells(4, ColT).Value = "Matt" Then AggG = "ina"
                        URC = Ws1.Cells(54, ColT).End(xlUp).Row + 1  '<<<<<<<<<<<<< vedi nota
                        Msg = Application.Proper(Format(Ws1.Cells(3, ColT).Value, "dddd") & " " & Ws1.Cells(4, ColT).Value & AggG) & vbCrLf
                        Msg = Msg & "Turnisti disponibili inferiori ai turni effettivi: " & vbCrLf
                        Msg = Msg & "Il turno sarà accodato"
                        If MSS = 0 Then MsgBox Msg
                        MSS = 1
                        Ws1.Cells(URC, ColT).Value = Turno & Rep
                        Ws1.Cells(URC, ColT).Interior.ColorIndex = Colore
                        Contaex = Contaex + 1
                        GoTo SaltaRT
                    End If
                End If
                Rcas = Int(Rnd(NC) * NC) + 24
                If Ws1.Cells(Rcas, ColT).Value <> "" Then GoTo RiprEx
                Ws1.Cells(Rcas, ColT).Value = Turno & Rep
                Ws1.Cells(Rcas, ColT).Interior.ColorIndex = Colore
                Contaex = Contaex + 1

            Else

Ripr:
                Rcas = Int(Rnd(NC) * NC) + 24
                MyC = Evaluate("=Min(" & NomeF & "!P24:P" & RigaC & ")")
                If Ws1.Cells(Rcas, ColT).Value <> "" Then GoTo Ripr
                If Ws1.Cells(Rcas, 16).Value <> MyC Then GoTo Ripr
                If Turno = 2 And Ws1.Cells(Rcas, ColT - 1).Value <> "" Then GoTo Ripr
                Ws1.Cells(Rcas, ColT).Value = Turno & Rep
                Ws1.Cells(Rcas, ColT).Interior.ColorIndex = Colore
            End If
        End If
SaltaRT:
    Next RT
Next RRL
Next ColT
End Sub


(*) Nota: Per avere i turni aggiunti ai responsabili, modifica la riga evindenziata con questa
Codice: Seleziona tutto
URC = Ws1.Cells(24, ColT).End(xlUp).Row + 1



Se hai altri problemi inviami il file con impostati i turni che danno problemi
spiegando cosa ottieni con la macro e cosa vorresti ottenere


ciao
Flash
Win7 + Office 2010 Ita
"Fotografica" al servizio dell'immagine

Ottime opportunità di lavoro (part-time o full-time) con guadagni immediati. Info in MP
Avatar utente
Flash30005
Moderatore
 
Post: 8460
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Sponsor
 

Re: Excel - Modfica macro di Flash30005

Postdi Sasyjoe » 27/09/12 17:28

Flash cortesemente leggi posta privata.

Grazie, sasyjoe!
Sasyjoe
Utente Senior
 
Post: 404
Iscritto il: 04/05/12 13:27

Re: Excel - Modfica macro di Flash30005

Postdi Flash30005 » 27/09/12 22:11

:?:
non ho nulla nella posta
intendi MP o email?
comunque non c'è nulla da nessuna delle due parti
(ovvero in email tra la posta inderiderata ho Aste Giudiziarie ma non credo sia tu :D )

ciao
Flash
Win7 + Office 2010 Ita
"Fotografica" al servizio dell'immagine

Ottime opportunità di lavoro (part-time o full-time) con guadagni immediati. Info in MP
Avatar utente
Flash30005
Moderatore
 
Post: 8460
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Excel - Modfica macro di Flash30005

Postdi Sasyjoe » 30/09/12 11:19

Ciao flash,
hai ricevuto mail di risposta venerdi ore 14:00 circa?
Ciao
Sasyjoe
Utente Senior
 
Post: 404
Iscritto il: 04/05/12 13:27

Re: Excel - Modfica macro di Flash30005

Postdi Sasyjoe » 02/10/12 13:20

Flash vuoi controllare adesso se ti è arrivata mail?

Allego comunque il testo della mail che ti ho scritto:

"Buongiorno Flash,
mi resta il problema seguente:
Se un collaboratore è non disponibile sia di mattina che pomeriggio la macro si blocca.

Ti invito a inserire “no” in cella L24 ed M24.

Spero riuscirai a risolvere questo, spero ultimo, problema.

Ciao Sasyjoe"

Ciao
Sasyjoe
Utente Senior
 
Post: 404
Iscritto il: 04/05/12 13:27

Re: Excel - Modfica macro di Flash30005

Postdi Flash30005 » 02/10/12 16:46

Codice: Seleziona tutto
Sub PrgTurni()
NomeF = ActiveSheet.Name
Set Ws1 = Worksheets(NomeF)
UCT = Ws1.Range("IV2").End(xlToLeft).Column
URT = Ws1.Range("A54").End(xlUp).Row
For RRT = 24 To URT
RigaC = RRT
If UCase(Mid(Ws1.Range("A" & RRT).Value, 1, 4)) <> "COLL" Or UCase(Right(Ws1.Range("A" & RRT).Value, 1)) = "X" Then Exit For
Next RRT
NC = RigaC - 23
Rep = ""
Ws1.Range("B14:O53").Interior.ColorIndex = xlNone
        For RRT = 14 To 53
            For CCT = 2 To UCT
                If UCase(Ws1.Cells(RRT, CCT).Value) <> "NO" Then
                Ws1.Cells(RRT, CCT).ClearContents
                End If
            Next CCT
        Next RRT
For ColT = 2 To UCT
ExtraS = 0
MSS = 0
Turno = "10-15"
Contaex = 0
If ColT Mod 2 = 1 Then Turno = "15-20"
For RRL = 5 To 9
Select Case RRL
Case 5
Colore = 6
Rep = "A"
Case 6
Colore = 50
Rep = "B"
Case 7
Colore = 41
Rep = "C"
Case 8
Colore = 15
Rep = "D"
Case 9
Colore = 8
Rep = "E"
End Select
NumP = Ws1.Cells(RRL, ColT).Value
    For RT = 1 To NumP
        If RT = 1 Then
            If Ws1.Cells(RRL + 9, ColT).Value = "" Then
                Ws1.Cells(RRL + 9, ColT).Value = Turno & Rep
                Ws1.Cells(RRL + 9, ColT).Interior.ColorIndex = Colore
            Else
                Ws1.Cells(RRL + 14, ColT).Value = Turno & Rep
                Ws1.Cells(RRL + 14, ColT).Interior.ColorIndex = Colore
            End If
        Else
            MyCNo = 0
            For RRC = 24 To RigaC
                If UCase(Cells(RRC, ColT).Value) = "NO" Then
                    MyCNo = MyCNo + 1
                End If
            Next RRC
            ST = 0
            For RRT = 5 To 9
                ST = ST + Cells(RRT, ColT).Value
            Next RRT
            Diff = ST - 5 - (NC - MyCNo)
            If NC - MyCNo <= ST - 5 Then
RiprEx:
'---------------
                If NC - MyCNo < ST - 5 Then
                    ExtraS = 1
                    If Contaex >= NC - MyCNo Then
                        AggG = "eriggio"
                        If Ws1.Cells(4, ColT).Value = "Matt" Then AggG = "ina"
                        Msg = Application.Proper(Format(Ws1.Cells(3, ColT).Value, "dddd") & " " & Ws1.Cells(4, ColT).Value & AggG) & vbCrLf
                        Msg = Msg & "Turnisti disponibili inferiori ai turni effettivi: " & vbCrLf
                        Msg = Msg & "Il turno sarà accodato"
                        If MSS = 0 Then MsgBox Msg
                        MSS = 1
                        Contaex = Contaex + 1
                        GoTo SaltaRT
                    End If
                End If
                Rcas = Int(Rnd(NC) * NC) + 24
                If Ws1.Cells(Rcas, ColT).Value <> "" Then GoTo RiprEx
                Ws1.Cells(Rcas, ColT).Value = Turno & Rep
                Ws1.Cells(Rcas, ColT).Interior.ColorIndex = Colore
                Contaex = Contaex + 1
            Else
Ripr:
                Rcas = Int(Rnd(NC) * NC) + 24
                MyC = Evaluate("=Min(" & NomeF & "!P24:P" & RigaC & ")")
                If Ws1.Cells(Rcas, ColT).Value <> "" Then GoTo Ripr
                If Ws1.Cells(Rcas, 16).Value <> MyC Then GoTo RiprEx
                If Turno = 2 And Ws1.Cells(Rcas, ColT - 1).Value <> "" Then GoTo Ripr
                Ws1.Cells(Rcas, ColT).Value = Turno & Rep
                Ws1.Cells(Rcas, ColT).Interior.ColorIndex = Colore
            End If
        End If
SaltaRT:
    Next RT
Next RRL

If ExtraS = 1 Then
MyMax = Application.WorksheetFunction.Max(Sheets("PreTurni").Range(Cells(5, ColT), Cells(9, ColT)))
MyMin = Application.WorksheetFunction.Min(Sheets("PreTurni").Range(Cells(5, ColT), Cells(9, ColT)))

RigaMin = 18
CV = 0
For RRM = MyMax To MyMin Step -1
    For RRT = 5 To 9
        If Ws1.Cells(RRT, ColT).Value = RRM Then
            CV = CV + 1
            Ws1.Cells(RRT + 9, ColT).Copy Destination:=Ws1.Cells(RRT + 14, ColT)
            For RRS = 24 To URT
                If Ws1.Cells(RRS, ColT).Value = Ws1.Cells(RRT + 9, ColT).Value Then
                    Ws1.Cells(RigaMin, ColT).Copy Destination:=Ws1.Cells(RRS, ColT)
                    Exit For
                End If
            Next RRS
            If CV = Diff Then GoTo EsciR
        End If
    Next RRT
Next RRM
EsciR:
End If
'-----------
Next ColT
End Sub


Spero di averlo risolto :)

ciao
Flash
Win7 + Office 2010 Ita
"Fotografica" al servizio dell'immagine

Ottime opportunità di lavoro (part-time o full-time) con guadagni immediati. Info in MP
Avatar utente
Flash30005
Moderatore
 
Post: 8460
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Excel - Modfica macro di Flash30005

Postdi Sasyjoe » 03/10/12 13:36

Is perfect!!!!!!!

Grazie 10000000 Flashhhh....
Sasyjoe
Utente Senior
 
Post: 404
Iscritto il: 04/05/12 13:27

Precedente

Torna a Applicazioni Office Windows


Topic correlati a "Excel - Modfica macro di Flash30005":


Chi c’è in linea

Visitano il forum: Anthony47 e 24 ospiti