ciao
al momento si blocca subito qui:
Moderatori: Anthony47, Flash30005
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
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"ora la macro non da errori
ma NON riporta in fgl reperibilita i nomi dai 3 fogli
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
si aspetta che date e "nomi" siano gia' inseriti
Torna a Applicazioni Office Windows
cerca il più grande numero di celle vuote in un intervallo Autore: papiriof |
Forum: Applicazioni Office Windows Risposte: 2 |
formula che conta erroneamente celle "vuote" Autore: raimea |
Forum: Applicazioni Office Windows Risposte: 4 |
excel vba eliminare celle apparentemente vuote Autore: ANTONIO1105 |
Forum: Applicazioni Office Windows Risposte: 3 |
Visitano il forum: Nessuno e 15 ospiti