- Codice: Seleziona tutto
Sub Dati()
'
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Foglio2")
Dim t As Date
Dim I As Integer
Dim X As Integer
Dim Y As Integer
Dim Headr As Long
t = Now
I = 1
X = 1
Y = 1
'Headr = 0
Application.ScreenUpdating = False
Range("B21").Select
'Imposta la serie 1, 2, ... in B21 e sottostanti
ActiveCell.Resize(10000, 1).ClearContents 'Prima azzeriamo la serie presente
ActiveCell.FormulaR1C1 = "1"
ActiveCell.AutoFill Destination:=ActiveCell.Resize([B5], 1), Type:=xlFillSeries
For I = 1 To [B4]
ActiveCell.Offset(0, 3).Range("A1").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(Foglio1!R21C:R3000C,Foglio2!RC2)"
'''CORTESEMENTE SE ANCHE QUESTA FORMULA ME LA TRASFORMATE IN CODICE
Next I
'FAREMO UN UNICO COPIA /INCOLLA VALORI, ALLA FINE
Cells(ActiveCell.Row, 2).Select
'COPIAMO LE FORMULE DELLA PRIMA RIGA SULLE RIGHE SOTTOSTANTI:
ActiveCell.Offset(0, 1).Resize(1, [B4] * 3 + 10).Copy _
Destination:=ActiveCell.Offset(1, 1).Resize([B5] - 1, 1)
Calculate
'COPIA /INCOLLA-VALORI FINALE:
Range("A21").Resize([B5], 1).EntireRow.Copy
Range("A21").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
Application.ScreenUpdating = True
MsgBox Format(Now - t, "HH:MM:SS"), vbInformation, "CODICE ESGUITO ...IN"
End Sub
La serie 1,2,3,.. l' ho creata con l' istruzione ActiveCell.AutoFill Destination:=ActiveCell.Resize([B5], 1), Type:=xlFillSeries
Poi ho creato una sola riga di formule, e l' ho copiata nelle righe sottostanti.
Infine ho trasformato tutto in Valori, con un solo Copia /Incolla speciale-valori.
I tempi di esecuzione sono di pochi secondi, penso che sia sufficiente per le tue esigenze.
Ciao
