- Codice: Seleziona tutto
Sub Roxx11()
Dim I As Long, J As Long, JJ As Long, OutSh As String, myArea As Range, aaaZ, aaaX, aaaC
'
OutSh = "PIPPO" '<< Foglio di uscita; vedi testo
'
myTim = Timer
If ActiveSheet.Name = OutSh Then
MsgBox ("Selezionare il foglio di partenza e ripetere")
Exit Sub
End If
Set myArea = ActiveSheet.UsedRange
aaaC = myArea.Columns.Count / 1
Sheets(OutSh).Cells.ClearContents
For I = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For J = 1 To Cells(I, Columns.Count).End(xlToLeft).Column
aaaX = Cells(I, J).Value
aaaZ = Application.WorksheetFunction.CountIf(myArea, aaaX)
If aaaZ > 1 Then
If aaaZ > Application.WorksheetFunction.CountIf(Cells(I, 1).Resize(1, aaaC), aaaX) _
And Application.WorksheetFunction.CountIf(Sheets(OutSh).Cells(I, 1).Resize(1, J), aaaX) = 0 Then
Sheets(OutSh).Cells(I, J).Value = aaaX
End If
Else
Sheets(OutSh).Cells(I, J).Value = aaaX
' JJ = JJ + 1
End If
DoEvents
Next J
DoEvents
'If I > 100 Then Exit For
Next I
'MsgBox (Timer - myTim)
End Sub
Ciao