cercare e prelevare celle unite

[raimea]

ciao

al momento si blocca subito qui:

[Anthony47]

Non so chi se l'e' mangiata, ma manca in quella posizione una riga! Aggiungila e riprova:

Codice: Seleziona tutto

Set tRan = Range("D6")

For D = 1 To 1000                                          'Pecorella SMARRITA da inserire
    If dRan.Cells(1, D) = "" Then Exit For
    cData = dRan.Cells(1, D).Value

[raimea]

ciao
quasi ok

ora la macro non da errori
ma NON riporta in fgl reperibilita i nomi dai 3 fogli

vanno riportati anche i nomi del reperibile
che si trova nel fgl 1_2_3



ciao

[Anthony47]

ora la macro non da errori
ma NON riporta in fgl reperibilita i nomi dai 3 fogli

Ma infatti la macro era stata pensata per estrarre dai 3 fogli le informazioni e si aspetta che date e "nomi" siano gia' inseriti nel foglio "reperibilita_mese"

Non volendo stravolgere il poco gia' fatto preferisco aggiungere il codice che serve per guardare nei "tre" fogli e portare in "reperibilita_mese" i nominativi che hanno reperibilità e poi procedere con il codice gia' pubblicato.

Il codice complessivo diventa:

Codice: Seleziona tutto

Sub CercaREGINA2()
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")
Sheets("reperibilita_mese").Select
Set dRan = Range("E5")
Set tRan = Range("D6")
'
'Estrazione Nomi dai fogli target
Dim DeSh As Worksheet
Dim iData, eData
'
Set DeSh = Sheets("reperibilita_mese")
DeSh.Range("D6").Resize(DeSh.UsedRange.Rows.Count, 50).ClearContents
For I = 0 To UBound(ShArr)
    With Sheets(ShArr(I))
        iData = Application.Match(CLng(DeSh.Range("E5")), .Range("A2").Resize(1, 2000), False)
        eData = Application.Match(CLng(DeSh.Range("E5").End(xlToRight).Value), .Range("A2").Resize(1, 2000), False)
        If Not IsError(iData) And (Not IsError(eData)) Then
            For J = 3 To .Cells(Rows.Count, "D").End(xlUp).Row
                If .Cells(J, "D").Value <> "" Then
                    If Application.WorksheetFunction.CountIf(.Range(.Cells(J + 1, iData), .Cells(J + 1, eData)), "Reper*") > 0 Or _
                      Application.WorksheetFunction.CountIf(.Range(.Cells(J + 1, iData), .Cells(J + 1, eData)), "R") > 0 Then
                        If Application.WorksheetFunction.CountIf(DeSh.Range("D1:D2000"), .Cells(J, "D")) = 0 Then
                            DeSh.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).Value = .Cells(J, "D").Value
                        End If
                    End If
                End If
            Next J
        End If
    End With
Next I
'
'Estrazione delle reperibilità:
For D = 1 To 1000
    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
'Azzera l'area dei risultati non compilata
DeSh.Cells(Rows.Count, "D").End(xlUp).Offset(1, 1).Resize(100, 50).Clear
MsgBox ("Completato...")
End Sub


Noterai la parte aggiunta in testa, prima di continuare col codice precedente. Ho inoltre aggiunto in coda la cancellazione dell'area non utilizzata dei risultati

Prova...

[raimea]

ciao

perfetta la macro REGINA2

tutto ok

mi spiace non essere stato abbastanza chiaro

si aspetta che date e "nomi" siano gia' inseriti

grazie