cercare e prelevare celle unite

[raimea]

ciao
vorrei riuscire a compilare l elenco
dei tecnici in reperibilita' nel mese indicato.

avviso subito che le celle da andare a cercare e prelevare
PURTROPPO sono state config con unisci cella !!!
quindi non so' se sara' possibile realizzare mia richiesta.

vorrei compilare il fgl reperibilita_mese

cercare nel fgl indicato in D4
( perche' poi il file originale e' composto da molti fogli)
partendo dalla data indicata in E5

prelevare il nome del tecnico
che ha la scritta >>> Reperibile
oppure >>> RINFORZO

e riuscire a prelevare e inserire la scritta in fgl reperibilita_mese
sotto alla data di inizio reperibilita'

so' che dovendo lavorare su "unisci celle" e' molto complicato.

spero di essermi spigato

vi allego un file

https://www.dropbox.com/s/5fgjvvna1s5646c/reperibilita_mese.rar?dl=0

grazie

[Anthony47]

Probabilmente funzionera' questa:

Codice: Seleziona tutto

Sub CercaRE()
Dim fV As Range, I As Long, istAdr As String
Dim lFor As String, lDate As Date, lsDate As Date, lastD As Long
Dim SC As Range, ccDate As Date, myX, myY, myZ0
'
Sheets("reperibilita_mese").Select
lDate = Range("D3").Value
lsDate = Application.WorksheetFunction.EDate(lDate, 1) - 1

myZ0 = Application.Match(CLng(lDate), Sheets(Range("D4").Value).Range("A2").Resize(1, 370), False)
If IsError(myZ0) Then
    MsgBox ("Fuori campo date: " & Format(lDate, "dd-mmm-yyyy"))
    Exit Sub
End If
If myZ0 > 5 Then myZ0 = myZ0 - 5 Else myZ0 = 1
lastD = Worksheets(Range("D4").Value).Cells(Rows.Count, "D").End(xlUp).Row + 3
Range("E6").Resize(200, 35).MergeCells = False
Range("AL7").Copy Range("E6").Resize(100, 35)
'
For I = 1 To 2
    If I = 1 Then lFor = "Reperibile" Else lFor = "RINFORZO"
    With Worksheets(Range("D4").Value).Cells(2, myZ0).Resize(lastD, 50)
        Set fV = .Find(lFor, LookIn:=xlValues)
        If Not fV Is Nothing Then
            istAdr = fV.Address
            Do
                Debug.Print fV.Address, lFor
                For Each SC In fV.MergeArea
                    ccDate = SC.Offset(-SC.Row + 2, 0).Value
                    If ccDate >= lDate And ccDate <= lsDate Then
                        myX = Application.Match(CLng(ccDate), Range("A5:AM5"), False)
                        myY = Application.Match(SC.Offset(0, 4 - SC.Column).MergeArea.Cells(1, 1).Value, Range("D1:D200"), False)
                        If Not IsError(myX) And Not IsError(myY) Then
                            Cells(myY, myX).Value = Left(lFor, 2)
                            Cells(myY, myX).Interior.Color = RGB(255, 255, 0)
                        End If
                    End If
                Next SC
                Set fV = .FindNext(fV)
'                If fV.Address = istAdr Then Exit Do
            Loop While Not fV Is Nothing And fV.Address <> istAdr
        End If
    End With
Next I
MsgBox ("Completato...")
End Sub


Ciao

[raimea]

ciao

la macro funziona


MA ho dimenticato io di specificare un passaggio

l elenco dei nomi nella colonna D6
deve essere aggiornato in relazione al foglio specificato in D4

quindi vanno cancellati i nomi presenti
e sostituiti con quelli del foglio indicato in D4

possibilmente i nomi di solo quelli che faranno reperibilita
( ma se non possibile anche tutti i nomi ).

Poi andare a prelevare la scritta >>> Reperibile
oppure >>> RINFORZO

pardon !

ringrazio

[Anthony47]

Mi sembrava strano, che i nominativi fossero gia' presenti... Preferisci solo i nominativi con servizi da evidenziare o tutti i nominativi presenti nel foglio richiamato?

Poi andare a prelevare la scritta >>> Reperibile
oppure >>> RINFORZO

Questa non la capisco

[raimea]

ciao

Mi sembrava strano, che i nominativi fossero gia' presenti... Preferisci solo i nominativi con servizi da evidenziare o tutti i nominativi presenti nel foglio richiamato?

preferirei solo i nominativi con servizi da evidenziare importare

grazie

[Anthony47]

Le modifiche sono poche, ma preferisco ripubblicare l'intero codice:

Codice: Seleziona tutto

Sub CercaRE()
Dim fV As Range, I As Long, istAdr As String
Dim lFor As String, lDate As Date, lsDate As Date, lastD As Long
Dim SC As Range, ccDate As Date, myX, myY, myZ0
'
Sheets("reperibilita_mese").Select
lDate = Range("D3").Value
lsDate = Application.WorksheetFunction.EDate(lDate, 1) - 1

myZ0 = Application.Match(CLng(lDate), Sheets(Range("D4").Value).Range("A2").Resize(1, 370), False)
If IsError(myZ0) Then
    MsgBox ("Fuori campo date: " & Format(lDate, "dd-mmm-yyyy"))
    Exit Sub
End If
If myZ0 > 5 Then myZ0 = myZ0 - 5 Else myZ0 = 1
lastD = Worksheets(Range("D4").Value).Cells(Rows.Count, "D").End(xlUp).Row + 3
Range("D6").Resize(200, 36).ClearContents
Range("E6").Resize(200, 35).MergeCells = False
Range("AL7").Copy Range("E6").Resize(100, 35)
'
For I = 1 To 2
    If I = 1 Then lFor = "Reperibile" Else lFor = "RINFORZO"
    With Worksheets(Range("D4").Value).Cells(2, myZ0).Resize(lastD, 50)
        Set fV = .Find(lFor, LookIn:=xlValues)
        If Not fV Is Nothing Then
            istAdr = fV.Address
            Do
                Debug.Print fV.Address, lFor
                For Each SC In fV.MergeArea
                    ccDate = SC.Offset(-SC.Row + 2, 0).Value
                    If ccDate >= lDate And ccDate <= lsDate Then
                        myX = Application.Match(CLng(ccDate), Range("A5:AM5"), False)
                        myY = Application.Match(SC.Offset(0, 4 - SC.Column).MergeArea.Cells(1, 1).Value, Range("D1:D200"), False)
                        If IsError(myY) Then
                            myY = Cells(Rows.Count, "D").End(xlUp).Row + 1
                            Cells(myY, "D").Value = SC.Offset(0, 4 - SC.Column).MergeArea.Cells(1, 1).Value
                        End If
                        If Not IsError(myX) And Not IsError(myY) Then
                            Cells(myY, myX).Value = Left(lFor, 2)
                            Cells(myY, myX).Interior.Color = RGB(255, 255, 0)
                        End If
                    End If
                Next SC
                Set fV = .FindNext(fV)
'                If fV.Address = istAdr Then Exit Do
            Loop While Not fV Is Nothing And fV.Address <> istAdr
        End If
    End With
Next I
MsgBox ("Completato...")
End Sub


Prova...

[raimea]

ciao
OTTIMO !

come sempre ,

e grazie mille

ciao

[Flash30005]

Ciao Raimea
spero di tornare presto attivo
ma ad ogni accesso ho sempre notato la "fluidità" e correttezza da parte degli utenti e soluzioni ottimali anche da utenti più "specializzati" che hanno reso il "lavoro", del moderatore, meno impegnativo.
Un Forum è composto da un innumerevole numero di utenti che chiedono e anche da altri che possono dare una soluzione senza alcun intervento del moderatore perché il Forum è di tutti.
Il moderatore ha funzioni, appunto, di moderare, (spam, post illeciti, illegali e tanto altro, poi, si sa se nessuno fornisce una soluzione il moderatore deve intervenire.
Per i neofiti: i Moderatori non hanno alcun compenso per essere qui, lo fanno solo per passione.
A presto!
Flash

[raimea]

ciao Flash30005
felice di ri-leggerti

per me, il forum pc-facile
e' una dei pochi con interventi sempre correti , mirati e coerenti con la sezione dell' argomento
e PRIVO di inutili , infinite.. discussioni polemiche.

io dal forum in anni , ho ottenuto MOLTO e di tutto,
ma in particolare sono almeno riuscito a gestire i codici VBA,
non sono in grado di crearne complessi da zero ma modificarli con vari "sfronzoli" si.
e questo solo grazie a pc-facile.

a presto Flash
ciao

[raimea]

ciao
solo dopo 2 mesi mi hanno gia complicato le reperibilita' :-(

mi hanno aggiunto la scritta Reperibile1 e R1 la domenica

la macro attuale --cercaRE --
funziona correttamente ,
mi preleva le scritte Reperibile , Reperibile1 e rinforzo

MA
non mi riconosce ( giustamente) la domennica con R1

se possibile vorrei scrivere nel fgl >>> reperibilita_mese
Re1 quando rileva Reperibile1 e R1

allego il foglio

https://www.dropbox.com/s/d0ubt08o8rulbjz/reperibile.rar?dl=0

grazie

[raimea]

azz....
(non posso piu modif il post sopra )
sfogliando i vari fogli che devo gestire
ho visto che c'e da gestire anche la scritta REP1 composta da solo 2 celle unite
sempre di lun_Mart

quindi:
se possibile vorrei scrivere nel fgl reperibilita_mese
Re1 quando rileva : Reperibile1 R1 (di domenica) e REP1

pardon

grazie
ciao

[Anthony47]

Sperando di aver capito bene, ti propongo questa variante di CercaRE:

Codice: Seleziona tutto

Sub CercaRE1()

Dim fV As Range, I As Long, istAdr As String
Dim lFor As String, lDate As Date, lsDate As Date, lastD As Long
Dim SC As Range, ccDate As Date, myX, myY, myZ0
'----------------------------------
' luglio 20
' preleva solo i tecn che fanno rep nel mese indicato
' dal sito pc-facile
' http://www.pc-facile.com/forum/viewtopic.php?f=26&t=111427&p=654430&sid=f11853eb39f3f1326cceb1dff8adaea6#p654430
'------------------------------------

Sheets("reperibilita_mese").Select
 
  UserForm1.Show vbModeless ' attiva immagine attendi
      DoEvents
       INIZIO = Timer
'-----------------------------------------------------------

lDate = Range("D3").Value
lsDate = Application.WorksheetFunction.EDate(lDate, 1) - 1

myZ0 = Application.Match(CLng(lDate), Sheets(Range("D4").Value).Range("A2").Resize(1, 370), False)
If IsError(myZ0) Then
 Unload UserForm1  ' chiude immag attendi
    MsgBox ("Fuori campo date: " & Format(lDate, "dd-mmm-yyyy"))
    Exit Sub
End If
If myZ0 > 5 Then myZ0 = myZ0 - 5 Else myZ0 = 1
lastD = Worksheets(Range("D4").Value).Cells(Rows.Count, "D").End(xlUp).Row + 3
Range("D6").Resize(200, 36).ClearContents
Range("E6").Resize(200, 35).MergeCells = False
Range("AL7").Copy Range("E6").Resize(100, 35)
'
'------->>>>
Dim lforA, insA                                                 'Nuovi
'
lforA = Array("Reperibile", "Reperibile1", "R1", "Rinforzo", "Rep1")    '<<< Array con i termini da cercare
insA = Array("Rep", "Re1", "Re1", "Rin", "Re1")                         '<<< Array con le voci da inserireFor I = 0 To UBound(lforA)                                              'M
    lFor = lforA(I)                                                     'M
    With Worksheets(Range("D4").Value).Cells(2, myZ0).Resize(lastD, 50)
        Set fV = .Find(lFor, LookIn:=xlValues, LookAt:=xlWhole)         'M
        If Not fV Is Nothing Then
            istAdr = fV.Address
            Do
                Debug.Print fV.Address, lFor
                For Each SC In fV.MergeArea
                    ccDate = SC.Offset(-SC.Row + 2, 0).Value
                    If ccDate >= lDate And ccDate <= lsDate Then
                        myX = Application.Match(CLng(ccDate), Range("A5:AM5"), False)
                        myY = Application.Match(SC.Offset(0, 4 - SC.Column).MergeArea.Cells(1, 1).Value, Range("D1:D200"), False)
                        If IsError(myY) Then
                            myY = Cells(Rows.Count, "D").End(xlUp).Row + 1
                            Cells(myY, "D").Value = SC.Offset(0, 4 - SC.Column).MergeArea.Cells(1, 1).Value
                        End If
                        If Not IsError(myX) And Not IsError(myY) Then
                            Cells(myY, myX).Value = insA(I)             'm
                            Cells(myY, myX).Interior.Color = RGB(255, 255, 0)
                        End If
                    End If
                Next SC
                Set fV = .FindNext(fV)
'                If fV.Address = istAdr Then Exit Do
            Loop While Not fV Is Nothing And fV.Address <> istAdr
        End If
    End With
Next I
'<<<---------

'------------------------------
Call colora_intero_mese
Call Nomi_Noturni
Call Nomi_replunga

Unload UserForm1  ' chiude immag attendi
     
   fine = Timer
   MsgBox ("Completato, Tempo impiegato " & Int((fine - INIZIO) / 60) & " min " & (fine - INIZIO) Mod 60 & " Sec")
   

MsgBox ("Completato...")
End Sub

La parte in cui sono intervenuto e' quella dopo la riga '------->>> e prima della riga '<<<-------
In particolare ho inserito 2 array che uso per dichiarare che cosa cercare e che cosa poi scrivere, e ovviamente qualche altra modifica "di contorno"
Fai sapere...

[raimea]

ciao
si blocca qui:



ciao

[Anthony47]

Non so come e' successo, ma questo pezzo in realta' devono essere due righe:

insA = Array("Rep", "Re1", "Re1", "Rin", "Re1") '<<< Array con le voci da inserireFor I = 0 To UBound(lforA) 'M

Cioe':

Codice: Seleziona tutto

insA = Array("Rep", "Re1", "Re1", "Rin", "Re1")                         '<<< Array con le voci da inserire
For I = 0 To UBound(lforA)                                              'M

Riprova...

[raimea]

ciao
e' tutto ok

speriamo che ora , per un po' non mi inventino altri turni "Marziani "

grazie

[Anthony47]

speriamo che ora , per un po' non mi inventino altri turni "Marziani "

Fino a Ferragosto possiamo stare tranquilli...

[raimea]

ciao
avrei bisogno di una nuova macro
o l ampliamento di quella attuale >>> Sub CercaRE1

seguendo quanto gia' fa correttamente la macro Sub CreaRE1
avrei bisogno di riportare i reperibili di ogni giorno in fgl reperibilita mese
MA prelevandoli non piu da un singolo foglio indicato in cella D4
( tramite menu tendina)

ma l insieme di 3 fogli : BS IS + BN IS DATI + BN IS FONIA

quindi x ogni giorno di fgl rep.mese riga 5,
andro a riportare il reper di fgl "1+2+3"

spero di essermi spiegato
via allego il file

https://www.dropbox.com/scl/fi/yvetmp1fkgvy6dwb1d4er/Reperibilita_X3.xlsm?rlkey=gvarrj4ttmrx388045urwupc4&dl=0

ciao

[Anthony47]

Ovviamente non ricordo niente della struttura dei tuoi dati; se puoi spendere due parole per descrivere quindi piu' in dettaglio la richiesta (che probabilmente impostero' con una nuova macro, visto che non ricordo niente nemmeno della Sub CercaRE1) avrai piu' chance di ottenere un aiutino...

[raimea]

ciao
certamente

Ovviamente non ricordo niente della struttura dei tuoi dati; se puoi spendere due parole per descrivere quindi piu' in dettaglio la richiesta (che probabilmente impostero' con una nuova macro, visto che non ricordo niente nemmeno della Sub CercaRE1) avrai piu' chance di ottenere un aiutino...

vorrei compilare il fgl reperibilita_mese
in relazione al giorno/mese di riga 5

per ogni giorno riportare il nome del reperibile che si trova in fgl
BS IS + BN IS DATI + BN IS FONIA Colonna D

nei 3 fogli il reperibile e' stato messo con la scritta
Reper. (in celle unite) e R

nel fgl reperibilita_mese il tecnico reperibile viene indicato con R

---------
avrei bisogno di una nuova macro
o l ampliamento di quella attuale >>> Sub CercaRE1

seguendo quanto gia' fa correttamente la macro Sub CreaRE1
avrei bisogno di riportare i reperibili di ogni giorno in fgl reperibilita mese
MA prelevandoli non piu da un singolo foglio indicato in cella D4
( tramite menu tendina)

ma l insieme di 3 fogli : BS IS + BN IS DATI + BN IS FONIA

quindi x ogni giorno di fgl rep.mese riga 5,
andro a riportare il reper di fgl "1+2+3"

spero di essermi spiegato
via allego il file

https://www.dropbox.com/scl/fi/yvetmp1fkgvy6dwb1d4er/Reperibilita_X3.xlsm?rlkey=gvarrj4ttmrx388045urwupc4&dl=0

ciao

[Anthony47]

Purtroppo la CercaRE1 fa delle cose che non capisco, mi limito quindi a una nuova macro che credo faccia la ricerca che dici.
Il codice:

Codice: Seleziona tutto

Sub CercaREGINA()
Dim myX, myY, ShArr
Dim dMatch, tMatch
Dim Sh As Long, T As Long, D As Long, cData As Long
Dim dRan As Range, tRan As Range
Dim strR As String, cTec As String

ShArr = Array("BS IS", "BN IS DATI", "BN IS FONIA")     '<<< Elenco fogli in cui cercare
Sheets("reperibilita_mese").Select
Set dRan = Range("E5")
Set tRan = Range("D6")

    If dRan.Cells(1, D) = "" Then Exit For
    cData = dRan.Cells(1, D).Value
   
    For T = 1 To 1000
        strR = ""
        If tRan.Cells(T, 1) = "" Then Exit For
        cTec = tRan.Cells(T, 1)
        For Sh = 0 To UBound(ShArr)
            With Sheets(ShArr(Sh))
                dMatch = Application.Match(cData, .Range("A2").Resize(1, 3650), False)
                tMatch = Application.Match(cTec, .Range("D1").Resize(1000, 1), False)
                If Not IsError(dMatch) And (Not IsError(tMatch)) Then
                    If UCase(Left(.Cells(tMatch + 1, dMatch).MergeArea.Cells(1, 1), 1)) = "R" Then
                        If Len(strR) = 0 Then
                            strR = "R" & Sh + 1
                        Else
                            strR = strR & Sh + 1
                        End If
                    End If
                End If
            End With
        Next Sh
        If Len(strR) > 0 Then
            dRan.Cells(T + 1, D).Value = strR
            dRan.Cells(T + 1, D).Interior.Color = RGB(255, 200, 0)
        Else
            dRan.Cells(T + 1, D).ClearContents
            dRan.Cells(T + 1, D).Interior.Color = xlNone
            If Weekday(cData, 2) = 7 Then
                dRan.Cells(T + 1, D).Interior.Color = RGB(150, 150, 150)
            Else
                dRan.Cells(T + 1, D).Interior.Color = xlNone
            End If
        End If
    Next T
Next D
MsgBox ("Completato...")
End Sub


La macro lavora sull'elenco dei fogli indicati nella variabile ShArr (marcata <<< nel codice)
La Sub CercaREGINA parte dal foglio "reperibilita_mese" e cerca giorno per giorno, nome per nome, foglio per foglio le "Reperibilità" e le riassume usando la notazione Rx, dove "x" e' la posizione del foglio all'interno di ShArr.
Ad esempio R1 indica la presenza nel foglio "BS IS" mentre R3 fa riferimento al foglio "BN IS FONIA" e R13 fa riferimento sia al primo che al terzo foglio (non so se puo' capitare)
Le reperibilita' vengono formattate in Arancione, le celle senza reperibilita' vengono lasciate senza colore, a parte le domeniche che vengono colorate in Grigio (il nero non mi piace)

Ciao