macro non più funzionante se spostata in personal

[velieromatrix]

Buongiorno a tutti,
ho creato questa macro che se lanciata dalla cartella di lavoro funziona alla perfezione ma se copiata in un modulo in personal non funziona più.
Ovviamente il problema è di fargli "riconoscere" gli activeworkbook e l'altro da cui prelevare i dati... il problema è che non riesco a trovare la soluzione!!!

Codice: Seleziona tutto

Sub certificatiok()
Dim Cell
Dim X As String
Dim percorso As String, nome As String, nomecompleto As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

ActiveSheet.Range("A13:P130").Select
    Range("A13:P130").Activate
    ActiveSheet.Range("$A$13:$P$130").AutoFilter Field:=1, Criteria1:="<>", Operator:=xlFilterValues
    For Each Cell In Range("o14:O130").SpecialCells(xlCellTypeVisible)
X = "C:\Documents and Settings\fgiudice\Desktop\MASTERS\" & (Cell.Value) & ".xlsx"
Workbooks.Open Filename:=X, ReadOnly:=False

ActiveWorkbook.Sheets("Foglio1").Cells(5, 3) = Foglio1.Cells(4, 2)
ActiveWorkbook.Sheets("Foglio1").Cells(5, 4) = Foglio1.Cells(6, 2)
ActiveWorkbook.Sheets("Foglio1").Cells(5, 9) = Foglio1.Cells(7, 2) & " " & Foglio1.Cells(8, 2)
ActiveWorkbook.Sheets("Foglio1").Cells(54, 10) = Foglio1.Cells(2, 5)

ActiveWorkbook.Sheets("Foglio1").Cells(9, 3) = Foglio1.Cells(Cell.Row, 2)
ActiveWorkbook.Sheets("Foglio1").Cells(9, 4) = Foglio1.Cells(Cell.Row, 5)
ActiveWorkbook.Sheets("Foglio1").Cells(9, 7) = Foglio1.Cells(Cell.Row, 6)
ActiveWorkbook.Sheets("Foglio1").Cells(9, 9) = Foglio1.Cells(Cell.Row, 8)
ActiveWorkbook.Sheets("Foglio1").Cells(9, 10) = Foglio1.Cells(Cell.Row, 7)
ActiveWorkbook.Sheets("Foglio1").Cells(11, 3) = Foglio1.Cells(Cell.Row, 11)
ActiveWorkbook.Sheets("Foglio1").Cells(11, 7) = Foglio1.Cells(Cell.Row, 13)
ActiveWorkbook.Sheets("Foglio1").Cells(2, 11) = Foglio1.Cells(Cell.Row, 16)

percorso = ActiveWorkbook.Path & "\"
nome = (Cell.Value) & "_" & ActiveWorkbook.Sheets("Foglio1").Cells(9, 9).Value & ".xlsx"
nomecompleto = percorso & nome
   
ActiveWorkbook.SaveAs Filename:=nomecompleto
ActiveWorkbook.Close

Next Cell

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Grazie a chi vorrà aiutarmi a rendere utilizzabile la macro da ogni scheda aperta!!

[velieromatrix]

Può sembrarvi una soluzione efficace?

Codice: Seleziona tutto

Sub certificatiok()
Dim F As Workbook
Dim M
Dim Cell
Dim X As String
Dim percorso As String, nome As String, nomecompleto As String
Dim myWKBook
Dim newWKBook

Application.ScreenUpdating = False
Application.DisplayAlerts = False

myWKBook = ActiveWorkbook.Name
ActiveSheet.Range("A13:P130").Select
    Range("A13:P130").Activate
    ActiveSheet.Range("$A$13:$P$130").AutoFilter Field:=1, Criteria1:="<>", Operator:=xlFilterValues
    For Each Cell In Range("o14:O130").SpecialCells(xlCellTypeVisible)
X = "C:\Documents and Settings\fgiudice\Desktop\MASTERS\" & (Cell.Value) & ".xlsx"
Workbooks.Open Filename:=X, ReadOnly:=False
newWKBook = ActiveWorkbook.Name
Workbooks(newWKBook).Sheets("Foglio1").Cells(5, 3) = Workbooks(myWKBook).Sheets("Foglio1").Cells(4, 2)
Workbooks(newWKBook).Sheets("Foglio1").Cells(5, 4) = Workbooks(myWKBook).Sheets("Foglio1").Cells(6, 2)
Workbooks(newWKBook).Sheets("Foglio1").Cells(5, 9) = Workbooks(myWKBook).Sheets("Foglio1").Cells(7, 2) & " " & Workbooks(myWKBook).Sheets("Foglio1").Cells(8, 2)
Workbooks(newWKBook).Sheets("Foglio1").Cells(54, 10) = Workbooks(myWKBook).Sheets("Foglio1").Cells(2, 5)

Workbooks(newWKBook).Sheets("Foglio1").Cells(9, 3) = Workbooks(myWKBook).Sheets("Foglio1").Cells(Cell.Row, 2)
Workbooks(newWKBook).Sheets("Foglio1").Cells(9, 4) = Workbooks(myWKBook).Sheets("Foglio1").Cells(Cell.Row, 5)
Workbooks(newWKBook).Sheets("Foglio1").Cells(9, 7) = Workbooks(myWKBook).Sheets("Foglio1").Cells(Cell.Row, 6)
Workbooks(newWKBook).Sheets("Foglio1").Cells(9, 9) = Workbooks(myWKBook).Sheets("Foglio1").Cells(Cell.Row, 8)
Workbooks(newWKBook).Sheets("Foglio1").Cells(9, 10) = Workbooks(myWKBook).Sheets("Foglio1").Cells(Cell.Row, 7)
Workbooks(newWKBook).Sheets("Foglio1").Cells(11, 3) = Workbooks(myWKBook).Sheets("Foglio1").Cells(Cell.Row, 11)
Workbooks(newWKBook).Sheets("Foglio1").Cells(11, 7) = Workbooks(myWKBook).Sheets("Foglio1").Cells(Cell.Row, 13)
Workbooks(newWKBook).Sheets("Foglio1").Cells(2, 11) = Workbooks(myWKBook).Sheets("Foglio1").Cells(Cell.Row, 16)

percorso = Workbooks(newWKBook).Path & "\"
nome = (Cell.Value) & "_" & Workbooks(newWKBook).Sheets("Foglio1").Cells(9, 9).Value & ".xlsx"
nomecompleto = percorso & nome
   
ActiveWorkbook.saveas Filename:=nomecompleto
ActiveWorkbook.Close

Next Cell

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[Anthony47]

Ciao velieromatrix, benvenuto nel forum.
Il problema e' l' uso dei Codename nelle istruzioni, es nelle righe del tipo

Codice: Seleziona tutto

ActiveWorkbook.Sheets("Foglio1").Cells(5, 3) = Foglio1.Cells(4, 2)     'Foglio1 e' un CodeName

Per definizione un codename fa riferimento al foglio del file che contiene la macro; da qui la necessita' di indicare in modo esplicito file e foglio Workbooks("IlNome").Sheets("IlFoglio"), come hai fatto con la seconda soluzione che hai pubblicato.
Se funziona va bene cosi', anche se:
-ti potevi risparmiare di indicare Workbooks(newWKBook)., perche' per definizione si fa riferimento al workbook attivo
-avresti postuto usare, invece di myWKBook = ActiveWorkbook.Name, la riga Set myWKBook = ActiveWorkbook.Sheets("Foglio1") e successivamente invece di Workbooks(myWKBook).Sheets("Foglio1").Cells(4, 2) usare myWKBook.Cells(4, 2)

Vale per le prossime volte.

Ciao

[velieromatrix]

Grazie mille!
Anche se nella prima stesura del codice avevo utilizzato ActiveWorkbook ma mi dava errore...

[velieromatrix]

Approfitto per richiedere un ulteriore piccolo aiuto:
è possibile far creare una nuova cartella nella stessa posizione del file da cui lancio la macro e che sia nominata in base ad una cella in esso contenuta contando che questa macro devo "distribuirla" (so come si fa per creare nuovi file ma non cartelle...)?
Tra le altre cose c'è un modo per rendere "universale" la cartella dove trovo i vari master? Ora nel codice è così: "C:\Documents and Settings\mionome\Desktop\MASTERS\" quindi oltre a salvare la macro in personal dovrei poi andare a modificare l'indirizzo nel codice di ogni pc a cui ho distribuito la macro....
Grazie in anticipo per l'aiuto!

[Anthony47]

Se per "Cartella" intendi una directory nel filesystem allora puoi partire da queste istruzioni:

Codice: Seleziona tutto

   Set fso = CreateObject("Scripting.FileSystemObject")
   Set newFold = fso.CreateFolder(ThisWorkbook.Path & "New_Folder")
   NewFolderFull = newFold.Path      'solo dimostrativa


Ti trovi (se puo' servire nel prosieguo della macro) la nuova cartella assegnata all' oggetto "newFold"

Con queste istruzioni avrai invece nella variabile "DirDTop" l' indirizzo del desktop dell' utente attivo:

Codice: Seleziona tutto

    Set wshshell = CreateObject("WScript.Shell")
    DirDTop = wshshell.SpecialFolders("MyDocuments")
    Set wshshell = Nothing

Quindi invece di usare "C:\Documents and Settings\mionome\Desktop\MASTERS\" userai
DirTop & "\MASTERS"
oppure
DirTop & "\" Range("A1").Value

Ciao

[Anthony47]

Un amico discreto mi ha fatto notare un paio di errori nel codice postato sopra:
1) This workbook.path restituisce un valore del tipo C:\Users\UTENTE\Documents, quindi non si deve usare (prima macro) ThisWorkbook.Path & "New_Folder" ma ThisWorkbook.Path & "\New_Folder"

2) Nella seconda macro, con SpecialFolders("MyDocuments") otterro' il path della cartella dei Documenti; se voglio quella del Desktop bisogna usare SpecialFolders("Desktop")

3) Poiche' il path e' messo nella variabile DirDTop, allora e' sbagliato successivamente usare una variabile DirTop che evidentemente sara' vuota.

Che dire... una performance abbastanza deludente...
Ciao!

[velieromatrix]

Grazie mille la creazione della directory e DirDTop funzionano perfettamente (per il momento l'ho potuto testare solo sul mio pc a dire il vero!)

Vorrei affinare il for each... ma ho difficoltà con le istruzioni stile .End (xlToRight)...
in pratica la macro deve filtrare le righe che hanno un quantitativo in colonna 1 a partire dalla riga 14 poi prende il nome del master da aprire dalla cella O lo popola lo salva ecc e passa alla riga successiva (cosa che attualmente fa in maniera egregia) ma ad oggi quando arriva alla cella O vuota da errore io vorrei bloccare il loop prima che accada... mi date il LA?? Graziee!

[velieromatrix]

risolto con

Codice: Seleziona tutto

For Each Cell In Range("o15:o97").SpecialCells(xlCellTypeVisible)
 
If Cell.Value <> "" Then

[velieromatrix]

Ho notato che ogni file creato "resta nella memoria VBA" ovvero nei progetti mi ritrovo tutti i file creati benchè abbia aggiunto :
ActiveWorkbook.saveas Filename:=nomecompleto
ActiveWorkbook.Close
Set NOME = Nothing
Set newWKBook = Nothing

perchè non funziona il clean up?
Questo rallenta notevolmente la macro...
Grazie per le vs gentili risposte!

[Zer0Kelvin]

Ciao.
Non ho capito cosa intendi con

ogni file creato "resta nella memoria VBA" ovvero nei progetti mi ritrovo tutti i file creati

Comunque, bisognerebbe almeno vedere il codice completo delle macro coinvolte.