Moderatori: Anthony47, Flash30005
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
Questa non la capiscoPoi andare a prelevare la scritta >>> Reperibile
oppure >>> RINFORZO
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?
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
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
insA = Array("Rep", "Re1", "Re1", "Rin", "Re1") '<<< Array con le voci da inserireFor I = 0 To UBound(lforA) 'M
insA = Array("Rep", "Re1", "Re1", "Rin", "Re1") '<<< Array con le voci da inserire
For I = 0 To UBound(lforA) 'M
Fino a Ferragosto possiamo stare tranquilli...speriamo che ora , per un po' non mi inventino altri turni "Marziani "
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...
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
Torna a Applicazioni Office Windows
Mettere tutto MAIUSCOLO un range di celle Autore: raimea |
Forum: Applicazioni Office Windows Risposte: 7 |
Trasformare celle con formattazioni in html Autore: servicedynergy |
Forum: Applicazioni Office Windows Risposte: 5 |
inserisci valore in celle a seguito di condizione Autore: ucame |
Forum: Applicazioni Office Windows Risposte: 10 |
Prelevare dati da www.forebet.com usando i Driver Selenium Autore: AndreaDeBiagi |
Forum: Applicazioni Office Windows Risposte: 5 |
Visitano il forum: Nessuno e 13 ospiti