Ciao Draleo,
Post by draleoPurtroppo invece la procedura di Norman, anche dopo la sua ultima modifica,
continua a presentare lo stesso problema: non elimina sul foglio1(o ne elimina
solo alcune), le righe che sono uguali nell' accoppiata codFiscale-articolo..
Queste vengono perfettamente copiate nel foglio2, ma NON vengono eliminate dal
foglio sorgente. Se i dati partono dalla riga 2, tutto funziona alla perfezione;
ma se sposto i dati alla riga 6, il problema si verifica. Probabilmente trattasi
di una banalità da correggere,ma le mie competenze in materia sono così scarse,
che non mi permettono di provare a mettere le mani in argomenti così complessi
come gli array ,le matrici o Scripting dictionary ecc.
Per quanto riguarda l'eliminazione delle righe sul Foglio1, il codice,
quando addattato per i tuoi dati, mancava l'inserimento della costante
iPrimaRiga nella parte del codice interessata. Ho aggiornato il file e
il codice diventa:
'=========>>
Option Explicit
'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim srcSH As Worksheet, destSH As Worksheet
Dim srcRng As Range, destRng As Range
Dim arrIn As Variant, arrOut() As Variant
Dim arrHeaders() As Variant, arrDelete() As Variant
Dim oDic As Object
Dim sStr As String, bStsr As String, sRows As String
Dim LRow As Long, UB As Long, UB2 As Long
Dim iCtr As Long
Dim i As Long, j As Long, k As Long
Dim p As Long, q As Long
Dim CalcMode As Long
Const sNomeFoglioDati As String = "Foglio1" '<<==== Modifica
Const sNomeFoglioDiCopia As String = "Foglio2" '<<==== Modifica
Const iPrimaRiga As Long = 6 '<<==== Modifica
Set WB = ThisWorkbook
Set oDic = CreateObject("Scripting.Dictionary")
oDic.CompareMode = 1 '\\ TextCompare
With WB
Set srcSH = WB.Sheets(sNomeFoglioDati)
Set destSH = .Sheets(sNomeFoglioDiCopia)
End With
With srcSH
LRow = LastRow(srcSH, .Columns("A:A"))
Set srcRng = .Range("A" & iPrimaRiga & ":F" & LRow)
End With
arrHeaders = srcRng.Rows(0).Value
arrIn = srcRng.Value
UB = UBound(arrIn, 1)
UB2 = UBound(arrIn, 2)
For i = LBound(arrIn, 1) To UB
For j = i + 1 To UB
If UCase(arrIn(i, 3)) = UCase(arrIn(j, 3)) _
And UCase(arrIn(j, 4)) = UCase(arrIn(i, 4)) Then
With oDic
If Not .exists(j + iPrimaRiga - 1) Then
.Add Key:=j + iPrimaRiga - 1, Item:=vbNullString
End If
End With
End If
Next j
Next i
iCtr = oDic.Count
If CBool(iCtr) Then
ReDim arrOut(1 To iCtr, 1 To UB2)
arrDelete = SortedList(oDic.keys)
For k = 1 To iCtr
For p = 1 To UB2
arrOut(k, p) = arrIn(arrDelete(k) - iPrimaRiga + 1, p)
Next p
Next k
On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With destSH
.UsedRange.Offset(1).ClearContents
.Range("A" & iPrimaRiga).Resize(1, UB2).Value = arrHeaders
.Range("A" & iPrimaRiga + 1). _
Resize(k - 1, UB2).Value = arrOut
End With
Dim myUnion As Range
For q = LBound(arrDelete) To UBound(arrDelete)
If myUnion Is Nothing Then
Set myUnion = srcSH.Rows(arrDelete(q))
Else
Set myUnion = Union(myUnion, srcSH.Rows(arrDelete(q)))
End If
Next q
Set myUnion = Intersect(myUnion, srcRng)
myUnion.Delete Shift:=xlUp
End If
XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'--------->>
Public Function SortedList(V As Variant)
Dim oSortedList As Object
Dim arrOut() As Variant
Dim vVal As Variant
Dim i As Long
Set oSortedList = CreateObject("System.Collections.Sortedlist")
With oSortedList
For i = LBound(V) To UBound(V)
vVal = V(i)
If Not vVal = vbNullString Then
If Not .ContainsKey(vVal) Then
.Add Key:=CLng(vVal), Value:=i
End If
End If
Next i
ReDim arrOut(1 To .Count)
For i = 0 To .Count - 1
arrOut(i + 1) = .GetKey(i)
Next i
End With
SortedList = arrOut
End Function
'--------->>
Public Function LastRow(SH As Worksheet, _
Optional Rng As Range, _
Optional minRow As Long = 1)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If
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
End Function
'<<=========
Ho aggiornato il mio file di prova su DropBox.
Per quanto riguarda i tuoi commenti a proposito della complessità del
codice, ciò è dovuto principalmente al fatto che io ho intenzionalmente
scelto di eseguire tutte manipolazione dei dati in memoria anziché
sfruttare strumenti speciali di Excel. La mia scelta è stata dettata da
una predilezione personale e il desiderio di accrescere l'efficienza di
esecuzione del codice.
===
Regards,
Norman