Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

tutti i turni in un foglio

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

tutti i turni in un foglio

Postdi raimea » 02/05/20 14:42

ciao
tramite una macro , vorrei riuscire a raggruppare i turni
di un singolo tec in un solo foglio >>> fgl "singolo "
e suddivisi x mese.

il tec da ricercare lo scrivo in cella D6
la data da cui partire a cercare e riportare in D3

il file e composto da molti fogli
quindi il foglio dove cercare e' scritto in D4

in fgl "singolo ", Nella prima riga R6 vorrei si riporti il giorno settimana
in D7 il giorno mese e i dati da riportare nel fgl "singolo " di origine sono di 2 righe

al cambiare del mese passare alla riga 10 di fgl "singolo "
riportare il gg settim giorno mese,
e sotto i relativi turni sempre composti da 2 righe da riportare

ad ogni cambio mese vorrei riuscire e passare alla riga sotto D14
e ripetere il tutto fino a quando ci sono date nel foglio dichiarato in D4

ovviamente al cambiare del nome o della data vanno cancellati i dati attualmente presenti
in fgl "singolo "

spero di essermi spiegato, il fgl singolo nel file l' ho compilato manualmente
x far capire , allego il file x test

NB nell immagine riporta 20 apr ma e un errore
ci dovrebbe essere scritto 1 maggio

Immagine

file:

https://www.dropbox.com/s/r09eyqx0rtwrocs/singolo_tec.rar?dl=0

ciao
Avatar utente
raimea
Utente Senior
 
Post: 1233
Iscritto il: 11/02/10 07:33
Località: lago

Sponsor
 

Re: tutti i turni in un foglio

Postdi Anthony47 » 02/05/20 23:11

Mahh... alcune cose me le sono inventate... Vediamo se ti soddisfa:
Codice: Seleziona tutto
Sub MeseByName()
Dim oSh As Worksheet, wName As String, daData As Date, sSh As Worksheet
Dim wRow, I As Long, LastC As Long, cMon As Long, olMon As Long
Dim oRow As Long, iK As Long, iSs As Long
'

Set oSh = Sheets("singolo")
Set sSh = Sheets(oSh.Range("D4").Value)
wName = oSh.Range("D6")
daData = oSh.Range("D3").Value
'
oRow = 6: iK = 6: iSs = 9
oSh.Cells(oRow, "E").Resize(33, 100).Clear
wRow = Application.Match(wName, sSh.Range("D1:D200"), False)
If IsError(wRow) Then
    MsgBox (wName & " NON TROVATO su foglio " & sSh.Name)
    Exit Sub
Else
    LastC = sSh.Cells(wRow, Columns.Count).End(xlToLeft).Column
    For I = iSs To LastC
        If sSh.Cells(2, I) >= daData Then
            cMon = Month(sSh.Cells(2, I))
            If cMon > olMon Then
                If olMon > 0 Then
                    olMon = cMon
                    oRow = oRow + 4
                    iK = 6
                Else
                    olMon = cMon
                End If
            End If
            sSh.Cells(1, I).Resize(2, 1).Copy oSh.Cells(oRow, iK)
            sSh.Cells(wRow, I).Resize(2, 1).Copy oSh.Cells(oRow + 2, iK)
            iK = iK + 1
        End If
        iSs = iSs + 1
    Next I
DoEvents
End If
MsgBox ("Completato...")
'
End Sub

Prova e commenta...
Avatar utente
Anthony47
Moderatore
 
Post: 17003
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: tutti i turni in un foglio

Postdi raimea » 03/05/20 06:40

ciao
la macro preleva come chiedevo
e gestisce i mesi correttamente nel fgl singolo.

attualmente ho notato 2 casi non ben gestiti:

1)_ se inserisco una data antecedente a quella realmente presente nel foglio in cui cercare
la macro parte a prelevare dalla prima data disponibile,
preferirei un messaggio tipo >>> data assente.

2__ nel prelevare la 2da riga di ogni tecnico
dove ci sara' solo la scritta >>> reperibile
fa confusione nel prelevarne il colore (di giallo)
cioe' colora o solo alcune celle o piu celle
che contengono la parola reperibile

ovviamente gia cosi andrebbe bene,
ma ho riportato i commenti richiesti.

grazie


Immagine
http://www.lelugarine.eu
S.O. Seven7, Excell 2010
Avatar utente
raimea
Utente Senior
 
Post: 1233
Iscritto il: 11/02/10 07:33
Località: lago

Re: tutti i turni in un foglio

Postdi Anthony47 » 03/05/20 20:37

Anthony ha scritto:Prova e commenta...

in risposta, raimea ha scritto:ovviamente gia cosi andrebbe bene, ma ho riportato i commenti richiesti.

La prossima volta imparo :D :D

Ho rivisto la macro anche alla luce di quel che hai scritto...
Quanto all'indicazione "Reperibile" tu usi purtroppo le celle unite e con cio' pensi di aver inserito l'indicazione in N celle, ma non e' cosi': l'indicazione e' solo nella cella iniziale, le altre sono occupate da quella visualizzazione ma hanno la loro identita', il proprio valore, la propria formattazione. Comunque, sapendolo, ho aggirato la cosa... Ma rimane il potenziale problema se "Reperibile" e' visualizzato a cavallo del transito di mese, nel qual caso copiero' la formattazione ma non la scritta.
Inoltre, ma questa e' stata una mia iniziativa estetica, ho allineato in verticale le date, così nella prima colonna avro' sempre il giorno 1; e ho aggiunto il mese in colonna E.
Infine, se la prima data utile e' posteriore a quella di inizio, il messaggio di "completato" lo indica.

Il nuovo codice:
Codice: Seleziona tutto
Sub MeseByName()
Dim oSh As Worksheet, wName As String, daData As Date, sSh As Worksheet
Dim wRow, I As Long, LastC As Long, cMon As Long, olMon As Long
Dim oRow As Long, iK As Long, iSs As Long, okFlag As Boolean, Msg As String
'
Set oSh = Sheets("singolo")
Set sSh = Sheets(oSh.Range("D4").Value)
wName = oSh.Range("D6")
daData = oSh.Range("D3").Value
'
olMon = Month(daData)
oRow = 6: iK = 4: iSs = 9
oSh.Cells(oRow, "E").Resize(33, 100).Clear
oSh.Cells(oRow + 1, "D").Resize(33, 100).Clear
DoEvents: DoEvents
'Application.ScreenUpdating = False
wRow = Application.Match(wName, sSh.Range("D1:D200"), False)
If IsError(wRow) Then
    MsgBox (wName & " NON TROVATO su foglio " & sSh.Name)
    Exit Sub
Else
    LastC = sSh.Cells(wRow, Columns.Count).End(xlToLeft).Column
    For I = iSs To LastC + 3
        If sSh.Cells(2, I) <= daData And I = iSs Then okFlag = True
        If sSh.Cells(2, I) >= daData Then
            cMon = Month(sSh.Cells(2, I))
            If oSh.Cells(oRow + 1, iK) = "" And olMon = cMon Then
                    oSh.Cells(oRow + 1, iK) = Format(sSh.Cells(2, I), "Mmm")
                    oSh.Cells(oRow + 1, iK).HorizontalAlignment = xlCenter
                    oSh.Cells(oRow + 1, iK).VerticalAlignment = xlCenter
            End If
            If cMon > olMon Then
                If olMon > 0 Then
                    oRow = oRow + 4 * 1  '(cMon - olMon)
                    olMon = cMon
                    iK = 4
                Else
                    olMon = cMon
                End If
            End If
            cday = Day(sSh.Cells(2, I))
            sSh.Cells(1, I).Resize(2, 1).Copy oSh.Cells(oRow, iK + cday)
            sSh.Cells(wRow, I).Resize(2, 1).Copy oSh.Cells(oRow + 2, iK + cday)
            oSh.Cells(oRow + 3, iK + cday).HorizontalAlignment = xlLeft
            oSh.Cells(oRow + 3, iK + cday).Interior.Color = sSh.Cells(wRow + 1, I).MergeArea.Cells(1, 1).Interior.Color
        End If
    DoEvents
    Next I
End If
Application.ScreenUpdating = True
If okFlag Then Msg = "Completato..." Else Msg = "Completato a partire da data successiva"
MsgBox Msg
'
End Sub


Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 17003
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: tutti i turni in un foglio

Postdi raimea » 03/05/20 20:53

ciao

immaginavo che il problema del - reperibile - fosse dovuto all unione celle
ma il file mi arriva cosi poi io devo lavorarci,
comunque confermo che e' stato risolto.

rimane problema della date precedente
se scrivo una data precedente , non presente nel fgl dove cercare
va in palla e lascia molte delle celle bianche e poi inizia a riportare
quelle presenti

Immagine

ottima l idea di scrivere a finco il mese

ciao
http://www.lelugarine.eu
S.O. Seven7, Excell 2010
Avatar utente
raimea
Utente Senior
 
Post: 1233
Iscritto il: 11/02/10 07:33
Località: lago

Re: tutti i turni in un foglio

Postdi raimea » 03/05/20 21:13

mi sono accorto solo ora e non posso piu modif post sopra

come si puo modific questo pezzo di codice per far si che appaia anche l anno ?

Codice: Seleziona tutto
If oSh.Cells(oRow + 1, iK) = "" And olMon = cMon Then
                    oSh.Cells(oRow + 1, iK) = Format(sSh.Cells(2, I), "Mmmm")
                    oSh.Cells(oRow + 1, iK).HorizontalAlignment = xlCenter
                    oSh.Cells(oRow + 1, iK).VerticalAlignment = xlCenter


ciao
http://www.lelugarine.eu
S.O. Seven7, Excell 2010
Avatar utente
raimea
Utente Senior
 
Post: 1233
Iscritto il: 11/02/10 07:33
Località: lago

Re: tutti i turni in un foglio

Postdi Anthony47 » 04/05/20 14:09

Gli spazi vuoti iniziali rappresentano i mesi mancanti nella query; se non li vuoi allora modifica questa riga:
Codice: Seleziona tutto
            If cMon > olMon Then
                If olMon > 0 And I > iSs Then                'MODIFICATA
                    oRow = oRow + 4 * 1  '(cMon - olMon)

Quanto alla formattazione, se vuoi Apr-2020 allora usa "mmm-yyyy"; se preferisci Aprile 2020 userai "mmmm-yyyy"

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 17003
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: tutti i turni in un foglio

Postdi raimea » 04/05/20 16:53

ciao

ottimo

tutto ok
grazie
http://www.lelugarine.eu
S.O. Seven7, Excell 2010
Avatar utente
raimea
Utente Senior
 
Post: 1233
Iscritto il: 11/02/10 07:33
Località: lago

Re: tutti i turni in un foglio

Postdi raimea » 19/05/20 05:43

ciao
ho dovuto ricostruire un foglio con date che partono da ottobre 2019
ma quando applico la macro >>> MeseByName

va in tilt al cambio dell' anno

se in fgl singolo scrivo dal 1-1-2020 tutto ok
preleva tutti i mesi presenti correttamente

se scrivo dal 7-10-19
preleva ottob-nov-dicem 19
e non va sotto a riportare gennaio 2020
riscrice sul mese di dicembre 2019

vi allego il file

https://www.dropbox.com/s/g8t96y46khhnx1v/test_2.rar?dl=0
http://www.lelugarine.eu
S.O. Seven7, Excell 2010
Avatar utente
raimea
Utente Senior
 
Post: 1233
Iscritto il: 11/02/10 07:33
Località: lago

Re: tutti i turni in un foglio

Postdi Anthony47 » 19/05/20 14:51

Eh gia', dovevo pensarci al cambio anno...

Nel calcolo di cMon e olMon ho inserito anche l'anno, questa mi sembra funzioni:
Codice: Seleziona tutto
Sub MeseByName2()
Dim oSh As Worksheet, wName As String, daData As Date, sSh As Worksheet
Dim wRow, I As Long, LastC As Long, cMon As Long, olMon As Long
Dim oRow As Long, iK As Long, iSs As Long, okFlag As Boolean, Msg As String
'
Set oSh = Sheets("singolo")
Set sSh = Sheets(oSh.Range("D4").Value)
wName = oSh.Range("D6")
daData = oSh.Range("D3").Value
'
olMon = Year(daData) * 100 + Month(daData)
oRow = 6: iK = 4: iSs = 9
oSh.Cells(oRow, "E").Resize(33, 100).Clear
oSh.Cells(oRow + 1, "D").Resize(33, 100).Clear
DoEvents: DoEvents
'Application.ScreenUpdating = False
wRow = Application.Match(wName, sSh.Range("D1:D200"), False)
If IsError(wRow) Then
    MsgBox (wName & " NON TROVATO su foglio " & sSh.Name)
    Exit Sub
Else
    LastC = sSh.Cells(wRow, Columns.Count).End(xlToLeft).Column
    For I = iSs To LastC + 3
        If sSh.Cells(2, I) <= daData And I = iSs Then okFlag = True
        If sSh.Cells(2, I) >= daData Then
            cMon = Year(sSh.Cells(2, I)) * 100 + Month(sSh.Cells(2, I))
            If oSh.Cells(oRow + 1, iK) = "" And olMon = cMon Then
                    oSh.Cells(oRow + 1, iK) = Format(sSh.Cells(2, I), "Mmm-yyyy")
                    oSh.Cells(oRow + 1, iK).HorizontalAlignment = xlCenter
                    oSh.Cells(oRow + 1, iK).VerticalAlignment = xlCenter
            End If
            If cMon > olMon Then
                If olMon > 0 And I > iSs Then                'MODIFICATA
                    oRow = oRow + 4 * 1  '(cMon - olMon)
                    olMon = cMon
                    iK = 4
                Else
                    olMon = cMon
                End If
            End If
            cday = Day(sSh.Cells(2, I))
            sSh.Cells(1, I).Resize(2, 1).Copy oSh.Cells(oRow, iK + cday)
            sSh.Cells(wRow, I).Resize(2, 1).Copy oSh.Cells(oRow + 2, iK + cday)
            oSh.Cells(oRow + 3, iK + cday).HorizontalAlignment = xlLeft
            oSh.Cells(oRow + 3, iK + cday).Interior.Color = sSh.Cells(wRow + 1, I).MergeArea.Cells(1, 1).Interior.Color
        End If
    DoEvents
    Next I
End If
Application.ScreenUpdating = True
If okFlag Then Msg = "Completato..." Else Msg = "Completato a partire da data successiva"
MsgBox Msg
'
End Sub

Ciao, fai sapere...
Avatar utente
Anthony47
Moderatore
 
Post: 17003
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: tutti i turni in un foglio

Postdi raimea » 19/05/20 19:00

ciao
e' tutto ok
Eh gia', dovevo pensarci al cambio anno...


e NO !
Antony47 fai gia tanto x noi
ci mancherebbe ti devi preoccupare x le infinite casistiche
che sono conseguenza di ogni lavoro !

le varie casistche ogni utente le deve poi estrapolare e giestire lui

ancora grazie

ciao
http://www.lelugarine.eu
S.O. Seven7, Excell 2010
Avatar utente
raimea
Utente Senior
 
Post: 1233
Iscritto il: 11/02/10 07:33
Località: lago


Torna a Applicazioni Office Windows


Topic correlati a "tutti i turni in un foglio":


Chi c’è in linea

Visitano il forum: Nessuno e 12 ospiti