tutti i turni in un foglio

[raimea]

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



file:

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

ciao

[Anthony47]

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...

[raimea]

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

[Anthony47]

Prova e commenta...

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

La prossima volta imparo

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

[raimea]

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



ottima l idea di scrivere a finco il mese

ciao

[raimea]

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

[Anthony47]

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

[raimea]

ciao

ottimo

tutto ok
grazie

[raimea]

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

[Anthony47]

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...

[raimea]

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