Ciao Andrea,
Salve,
innanzitutto ringrazio per la risposta e devo dire che ha risolto in buona parte la questione. Va detto che il foglio è pesante a livello di calcolo, cosa peraltro anticipata , e ad ogni modifica o apertura mette al massimo l'utilizzo del computer per diversi
minuti. Mi trovo infatti un file mensile con circa 10000 righe e sto pensando a come semplificare il processo di ricerca.
Ovvero immettere solo 3 intervalli: nome, ditta, data (data senza ora) tralasciando il dato di numero badge ed in-out in quanto è sufficiente che sia presente 1 record per giorno per considerarlo. Il numero badge è superfluo perché considero che il badge
sia personale e non cedibile, IN-OUT rimando questo controllo ad un secondo momento.
Credo basti adattare le formule sopra, ci proverò ma sennò se ci sono ulteriori suggerimenti ben vengano.
Per sfruttare un approccio VBA, che dovrebbe essere molto veloce ed efficiente, anche con migliaia di record, prova qualcosa del genere:
- Alt+F11 per aprire l'editor di VBA
- Alt+IM per inserire un nuovo modulo di codice
- Nel nuovo modulo vuoto, incolla il seguente codice:
'=========>>
Option Explicit
'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim srcSH As Worksheet, reportSH As Worksheet
Dim srcRng As Range, destRng As Range, tableRng As Range
Dim arrIn As Variant, arrOut() As Variant
Dim arrHeaders As Variant, arrJoin As Variant
Dim oDic As Object
Dim sStr As String
Dim LRow As Long
Dim i As Long, j As Long, k As Long
Dim iCtr As Long
Dim UB As Long, UB2 As Long
Dim CalcMode As Long
Const sFoglioDati As String = "Foglio1"
'<<=== Modifica
Const sFoglioReport As String = "Foglio2" '<<=== Modifica
Set WB = ThisWorkbook
With WB
Set srcSH = .Sheets(sFoglioDati)
Set reportSH = .Sheets(sFoglioReport)
End With
reportSH.UsedRange.ClearContents
With srcSH
LRow = LastRow(srcSH, .Columns("A:A"))
Set srcRng = .Range("A2:E" & LRow)
End With
arrIn = srcRng.Value2
arrHeaders = srcRng.Rows(0).Value
UB = UBound(arrIn)
UB2 = UBound(arrIn, 2)
ReDim arrOut(1 To UB, 1 To UB2)
ReDim arrJoin(1 To UB2)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
.CompareMode = vbTextCompare
For i = 1 To UB
arrJoin(1) = arrIn(i, 1)
arrJoin(2) = arrIn(i, 2)
arrJoin(3) = arrIn(i, 3)
arrJoin(4) = CLng(arrIn(i, 4))
arrJoin(5) = arrIn(i, 5)
sStr = Join(arrJoin, "-")
If Not .exists(sStr) Then
.Add Key:=sStr, Item:=Nothing
iCtr = iCtr + 1
For j = 1 To UB2
arrOut(iCtr, j) = arrIn(i, j)
Next j
End If
sStr = vbNullString
Next i
End With
If CBool(iCtr) Then
' On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set destRng = reportSH.Range("A2").Resize(iCtr, UB2)
With destRng
.Rows(0).Value = arrHeaders
.Value = arrOut
.Columns(2).ColumnWidth = 30
.Columns(3).ColumnWidth = 25
With .Columns(4)
.NumberFormat = "dd/mm/yyyy hh:mm"
.ColumnWidth = 20
End With
Set tableRng = .Offset(-1).Resize(iCtr + 1)
With tableRng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
reportSH.ListObjects.Add( _
xlSrcRange, tableRng, , xlYes).Name = "TabellaFiltrata"
End If
Call MsgBox( _
Prompt:="Finito!", _
Buttons:=vbInformation, _
Title:="REPORT")
XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
Set oDic = Nothing
End Sub
'--------->>
Public Function LastRow(SH As Worksheet, _
Optional Rng As Range, _
Optional minRow As Long = 1, _
Optional sPassword As String)
Dim bProtected As Boolean
With SH
If Rng Is Nothing Then
Set Rng = .Cells
End If
bProtected = .ProtectContents = True
If bProtected Then
.Unprotect Password:=sPassword
End If
End With
On Error Resume Next
LastRow = Rng.Find(What:="*", _
after:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
If LastRow < minRow Then
LastRow = minRow
End If
If bProtected Then
SH.Protect Password:=sPassword, _
UserInterfaceOnly:=True
End If
End Function
'<<=========
- Alt+Q per chiudere l'editor di VBA e tornare a Excel
- Salva il file con l’estensione xlsm
- Alt+F8 per aprire la finestra di gestione delle macro
- Seleziona Tester
- Esegui
Potresti scaricare il mio file di prova Andrea20180102.xlsm
===
Regards,
Norman
![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
