Allora, vediamo di stringere...
Dal tuo codice ho capito che le celle da prelevare da Riassunto e scrivere sul file di uscita, foglio "Scheda", sono:
B2 --> C6 (vedi nota 1)
D2 --> G23
E2 --> G25
F2 --> G19
G2 --> G21
I2 --> G31
J2 --> G41
K2 --> G45
L2 --> G47
Nel ciclo successivo tutte le celle di origine scivolano di una posizione verso il basso, mentre la destinazione rimane invariata.
Nota1: la cella C6 viene sistematicamente compilata come detto sopra, salvo che poi detto valore viene sostituito col nominativo che sara' usato cone nome file. Tanto varrebbe allora evitare di copiare B2 in C2... ma B2 e sottostanti in realta' gia' contengono il nominativo che sara' usato per salvare il file, quindi in realta' quello che non capisco e' perche', dopo aver fatto la copia in C6 di un valore che dovrebbe gia' essere giusto, riscrivi in C6 lo stesso valore.
Nell' ignoranza ho mantenuto il tuo ciclo, e in C6 ci scrivo il nome del file.
Cio' detto,
-ho estratto dal tuo codice un solo ciclo
-l' ho inserito in un loop per ripeterlo il numero di volte che e' scritto in B16; la macro comunque si interrompe se Bxx e' vuota.
-ho modificato la selezione delle celle da cui copi i valori
-ho modificato la selezione del secondo workbook, che ora ha un nome variabile
-ho modificato la directory di salvataggio file, che NON E' PIU' direttamente il desktop ma una directory PIPPO posizionata sul desktop; questa directory la devi creare prima di avviare la macro.
Il risultato e' questa macro:
- Codice: Seleziona tutto
Sub Prova2()
'
' Prova Macro
'
Dim StartNm As String, I As Long, LoopCNT As Long, FName As String, WB2 As String
'
StartNm = "B2" '<<< La cella dove COMINCIANO i nomi da usare nel SalvaConNome
'
LoopCNT = Range("B16").Value
Workbooks.Open Filename:="C:\Users\Sara.PC-Sonia\Desktop\File di base.xls"
WB2 = ActiveWorkbook.Name
'Application.ScreenUpdating = False
'
For I = 1 To LoopCNT
FName = ThisWorkbook.Sheets("scheda").Range(StartNm).Offset(I - 1, 0).Value
If FName = "" Then Exit For
If Right(FName, 4) <> ".xls" Then FName = FName & ".xls"
'
Windows("Riassunto.xlsm").Activate
Sheets("scheda").Select
Range("B2").Offset(I - 1, 0).Select
Selection.Copy
Windows(WB2).Activate
ActiveWindow.SmallScroll Down:=-13
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Riassunto.xlsm").Activate
Range("D2").Offset(I - 1, 0).Select
Application.CutCopyMode = False
Selection.Copy
Windows(WB2).Activate
Range("G23").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Riassunto.xlsm").Activate
Range("E2").Offset(I - 1, 0).Select
Application.CutCopyMode = False
Selection.Copy
Windows(WB2).Activate
Range("G25").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Riassunto.xlsm").Activate
Range("F2").Offset(I - 1, 0).Select
Application.CutCopyMode = False
Selection.Copy
Windows(WB2).Activate
Range("G19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Riassunto.xlsm").Activate
Range("G2").Offset(I - 1, 0).Select
Application.CutCopyMode = False
Selection.Copy
Windows(WB2).Activate
Range("G21").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Riassunto.xlsm").Activate
Range("I2").Offset(I - 1, 0).Select
Application.CutCopyMode = False
Selection.Copy
Windows(WB2).Activate
ActiveWindow.SmallScroll Down:=3
Range("G31").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Riassunto.xlsm").Activate
Range("J2").Offset(I - 1, 0).Select
Application.CutCopyMode = False
Selection.Copy
Windows(WB2).Activate
ActiveWindow.SmallScroll Down:=8
Range("G41").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Riassunto.xlsm").Activate
Range("K2").Offset(I - 1, 0).Select
Application.CutCopyMode = False
Selection.Copy
Windows(WB2).Activate
ActiveWindow.SmallScroll Down:=6
Range("G45").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Riassunto.xlsm").Activate
Range("L2").Offset(I - 1, 0).Select
Application.CutCopyMode = False
Selection.Copy
Windows(WB2).Activate
Range("G47").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-20
Range("C6").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = FName ' ??? "Samuel"
' ChDir "C:\Users\Sara.PC-Sonia\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\Sara.PC-Sonia\Desktop\PIPPO\" & FName, FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
WB2 = ActiveWorkbook.Name
Next I
ActiveWindow.Close
Application.ScreenUpdating = True
End Sub
Controlla il contenuto dell' istruzione marcata <<<.
Lo schermo ballera' tutto durante l' esecuzione della macro, visto che si seleziona in continuazione un file e l' altro; scandaloso per i programmatori che hanno un mese di esperienza, eccitante per i dilettanti alle prime armi che vedono come una macro che hanno registrato con le proprie mani con poche modifiche risolve problemi complessi.
Basterebbe mettere "Application.ScreenUpdating = False" all' inizio del codice per non vedere piu' questa animazione (in realta' basta togliere l' apostrofo in testa all' istruzione inserita verso l' inizio del loop).
Quando confermi che funziona, a scopo puramente dimostrativo, vedremo come puoi condensare il grosso della macro in 10 righe.
Ciao