applicare macro a una lista di file chiusi

[luca62]

Salve, devo modificare circa 3000 file con una macro che mi crei due colonne nuove e ci scriva dei dati già esistenti
in quel file.In alternativa posso copiare questi 3000 file e quindi applicarci la stessa macro.
è possibile fare "qualcosa " che mi applichi questa macro che allego a tutti dile contenuti nella directory PIPPO ?

Codice: Seleziona tutto

Sub Macro2()
'
' Macro2 Macro
'

'
    Range("M9").Select
    ActiveSheet.Unprotect
    Columns("C:C").Select
    Selection.Copy
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("G:G").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Range("B1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = ""
    Range("A1").Select
    ActiveCell.FormulaR1C1 = ""
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "DESCRIZIONE"
    With ActiveCell.Characters(Start:=1, Length:=11).Font
        .Name = "Arial"
        .FontStyle = "Grassetto"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "NUMERO"
    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Arial"
        .FontStyle = "Grassetto"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "=R1C5"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "=R1C8"
    Range("A3:B3").Select
    Selection.Copy
    Range("A4:B47").Select
    ActiveSheet.Paste
    Range("B2").Select
    Application.CutCopyMode = False
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

[luca62]

Modifico la richiesta perchè mi rendo conto di aver fatto un po di casino.
La mia esigenza è di costruirmi un file riepilogo che mi vada a copiare 4 colonne da 3000 file.
In sostanza mi dovrebbe copiare tutte le righe (tutte quelle dalla 3^ in poi in cui il valore nella colonna d sia diverrso da zero ) come da codice allegato .(massimo ho 15 righe compilate per ciascun file).
Il nome del file dal quale devo andare a copiare lo dovrei andare a trovare da un file LISTA , dove nella colonna
A scrivo tutti i nome dei file.
(A1, ci sarà il primo file, A2 il secondo e così via.)
SCimmiottando un codice fatto da Anthony ho scritto questo,

Codice: Seleziona tutto

Private Sub Worksheet_Activate()
ActiveSheet.Unprotect
Dim myBase(1 To 4)
myBase(1) = "'H:\produzione\scheda preventivo\[ZCZCX'!$c$1"    (deve rimanere il valore  c1 su tutte le righe)
myBase(2) = "'H:\produzione\scheda preventivo\[ZCZCX'!$f$1"     (deve rimanere il valore  cf1 su tutte le righe)
myBase(3) = "'H:\produzione\scheda preventivo\[ZCZCX'!A3"
myBase(4) = "'H:\produzione\scheda preventivo\[ZCZCX'!b3"

Application.EnableEvents = False
LastA = Cells(Rows.Count, 1).End(xlUp).Row
For I = 1 To 4
    [i][b]Cells(3, 1 + I).Resize(LastA - 3, 1).FormulaLocal = "=" & Replace(myBase(I), "[ZCZCX", Range("$A$1").Value)[/b][/i]
 Next I
Application.EnableEvents = True

ActiveSheet.Protect

End Sub

Dove ovviamente devo cambiare il riferimento dei nomi dei file (ossia quello che deve sostituire il ZCZCX
prelevandolo dalla lista
è possibile?

[Anthony47]

Non ho capito se vuoi costruirti un file di riepilogo che contenga i dati prelevati da 3000 file o se invece vorresti volta per volta prelevare informazioni da un file specifico che indichi al momento. Puoi chiarire?

[luca62]

Anthony,
io devo costruirmi un file di riepilogo estraendo dati da circa 3000 file.
Questi file da cui ricavare i dati sono tutti posti nella stessa directory (H:\produzione\scheda preventivo\)ed i nomi dei file sono alfanumerici.
da ciascun file vorrei recuperare per inserire nel file di riepilogo tutte le colonne secondo questa logica:

myBase(1) = "'H:\produzione\scheda preventivo\[ZCZCX'!$c$1"
myBase(2) = "'H:\produzione\scheda preventivo\[ZCZCX'!$f$1"
myBase(3) = "'H:\produzione\scheda preventivo\[ZCZCX'!A3"
myBase(4) = "'H:\produzione\scheda preventivo\[ZCZCX'!b3"

(in realtà le colonne sono molte di più ho messo 4 per brevità, arrivo a 16 colonne
con nella colonna 5 del riepilogo c3...fino alla colonna 16 con N3)

per tutte le righe in cui il valore nella colonna d è diverso da zero.
Il file di riepilogo sarà n file che avrà esempio:
le riga n^ 1 come intestazione
le righe da 2-6^ prese dal primo file,
le righe da 7^ 18^ dal secondo file
le righe dal 19^ 25^ dal terzo file e così via.

spero di aver chierito

[luca62]

troppo complicato?.. o impossibile ? o..mi sono espresso male?

[Anthony47]

troppo complicato?.. o impossibile ? o..mi sono espresso male?

No, solo problema troppo noioso per applicarsi...

Comunque, volendo lo stesso applicarsi, devi spiegare perche' hai immaginato di risolverlo con formule che collegano a 3000 file diversi; una bella sfida se si mette a ricalcolare...
In particolare:
-e' una cosa che devi fare spesso o "ogni tanto"
-una volta importati i dati su questo file riassuntivo, e' possibile che qualcuno dei file di origine cambi? Se Si, ti interessa aggiornare il contenuto del riassunto o, nel caso, e' meglio ricreare il (/un altro) riassunto?
-le strutture dei 3000 file sono tutte uguali?
-quale e' il nome del foglio da cui copiare? O contengono solo 1 foglio?
-ho capito che, su ogni file, bisogna sondare la colonna D di ogni riga; non ho capito invece quali colonne vanno copiate e su quali colonne del Riepilogo vanno incollate.

Rispondi in fretta altrimenti mi torna un attacco di pigrizia...

[luca62]

HAI RAGIONE, NON SO IL MOTIVO...
ti posto un file di partenza e il file desiderato di riepilogo, con inseriti i dati da due file:
https://www.dropbox.com/s/0j3lvjjyiyi0a ... O.xls?dl=0
https://www.dropbox.com/s/03j7430au58dg ... 9.xls?dl=0
è un file che via via vado ad incrementare con nuovi file o aggiungendo altre righe ai file esistenti
non necessito di aggiornarlo spesso, anche se pensavo di crearmi una macro per aggiornamento di notte.
(sarebbe sufficiente una volta al giorno) e mi basta aggiornare il contenuto (non mi interessa di tenere i vari files
riepilogo)
le strutture dei file sono tutte uguali.
Io devo andare a copiare tutti i dati delle righe dei file di partenza ,(ossia tutte le righe dalla 3^ (inclusa ) in poi con aggiunta due colonne in cui la colonna
A mi vada a prendere i dati del nome del file (il numero senza estensione) e la colonna B la descrizione che nei
3000 files sono sempre alla solita posizione C1 e F1.
spero di essermi fatto capire
I

[Anthony47]

Hai saltato di indicare "quale e' il nome del foglio da cui copiare", quindi assumero' che sia sempre "il primo".
Dovrebbe aiutare questa macro, da inserire nel file su cui va creato il riepilogo, in un Modulo standard del vba:

Codice: Seleziona tutto

Sub resuMaker()
Dim myPath As String, Rispo, WbDest As Worksheet, myTim As Single, myNext As Long, myCFile As String
Dim myRCnt As Long, myFCnt As Long
'
ThisWorkbook.Activate
Sheets("Foglio1").Select            '<<< Il foglio dove verra' creato il riepilogo
myPath = "D:\PIPPO\Peppa\"          '<<< Il path dei fogli di origine, con \ finale

Set WbDest = ThisWorkbook.ActiveSheet

'Check Ricrea vs Append:
Rispo = MsgBox("Vuoi RICREARE il riepilogo?" & vbCrLf & _
    "-Premi SI per Cancellare l'elenco esistente e crearne uno nuovo" & vbCrLf & _
    "-Premi NO per AGGIUNGERE righe all'elenco esistente (solo file Nuovi)" & vbCrLf & _
    "-Premi Annulla per terminare la macro senza modifiche al foglio", vbYesNoCancel)
If Rispo = vbCancel Then
    Exit Sub
ElseIf Rispo = vbYes Then
    Range(Range("A2"), Range("A2").End(xlDown)).Resize(, 15).ClearContents
ElseIf Rispo <> vbNo Then
    Exit Sub
End If


myTim = Timer
'mynext = wbdest.Cells(Rows.Count, 1).End(xlUp)
Application.EnableEvents = False
Application.ScreenUpdating = False

myCFile = Dir(myPath & "*.xls*")
Do
DoEvents
    If myCFile = "" Then Exit Do
    myNext = WbDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Application.WorksheetFunction.CountIf(WbDest.Range("A:A"), Replace(Replace(myCFile, ".xlsx", "", , , vbTextCompare), ".xls", "", , , vbTextCompare)) = 0 Then
    Workbooks.Open myPath & myCFile
    Sheets(1).Select
    For i = 3 To Cells(Rows.Count, "D").End(xlUp).Row
        If Cells(i, "D").Value <> "" Then
            WbDest.Cells(myNext, 1) = Replace(Replace(myCFile, ".xlsx", "", , , vbTextCompare), ".xls", "", , , vbTextCompare)
            WbDest.Cells(myNext, 2) = Range("F1").Value
            WbDest.Cells(myNext, 3).Resize(1, 13).Value = Cells(i, 1).Resize(1, 13).Value
            myNext = myNext + 1
            myRCnt = myRCnt + 1
        End If
    Next i
    myFCnt = myFCnt + 1
    ActiveWorkbook.Close False
End If
myCFile = Dir
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox ("Completato, sec.  " & Format(Timer - myTim, "0.0") & vbCrLf & _
    "Record inseriti: " & myRCnt & " da " & myFCnt & " file")
Range(Range("P3"), Range("P3").End(xlDown)).Clear
Range("P2:P" & myNext + 10).FillDown
End Sub


Le istruzioni marcate <<< vanno compilate come da commenti

All'inizio la macro chiede se vuoi creare daccapo il riepilogo, cancellando l'esistente, o se vuoi Accodare nuovi record al riepilogo corrente.
Saranno "accodati" solo record provenienti da file non ancora presenti nel riepilogo; quindi se sai che sono stati modificati dei file preesistenti devi creare daccapo il riepilogo.

Con 1000 file di 20 righe ciascuno, la macro impiega 2-3 minuti, quindi sai cosa aspettarti con 3000 file.
La formula di colonna P viene applicata, copiandola da P2, su tutti i record presenti nel riepilogo.

Prova e fai sapere...

[luca62]

anthony tutto ok!, ho fatto qualche aggiustamento ma funziona benissimo
con 2500 fles e circa 5400 righe copiate i tempi sono 710 secondi
grazie ancora