[EXCEL] codice macro vba...aiuto!!

[luana76]

...vi prego aiutatemi!!!

ho bisogno di una macro per fare questo:

ho 12 cartelle in una cartella ''mesi'' in cui ci sono per ogni mese i rispettivi giorni,
esempio:
C:\Users\...\mesi\gennaio\1.xls
C:\Users\...\mesi\gennaio\2.xls
...
C:\Users\...\mesi\gennaio\31.xls
C:\Users\...\mesi\febbraio\1.xls
..
C:\Users\...\mesi\febbario\28.xls
..etc etc
tutti i file .xls nelle varie cartelle con i nomi dei mesi sono uguali come struttura, io devo solo copiare per ogni file la colonna da b3 a b5 incluse, in un nuovo file ''archivio.xls'' che metto nella directory mesi
C:\Users\...\mesi\archivio.xls
dove copio in ogni riga del file archivio.xls la colonna presa dalle varie cartelle mantenendo un ordine cronologico dal 1 gennaio fino al 31 dicembre
esempio:
- in a1:h1 del file archivio.xls la colonna b3:b5 del file 1.xls nella cartella
C:\Users\...\mesi\gennaio\1.xls
- in a2:h2 del file archivio.xls la colonna b3:b5 del file 2.xls nella cartella
C:\Users\...\mesi\gennaio\1.xls
etc etc

Spero di essere stata chiara, se mi scrivete il codice vba vi ringrazierò per l'eternità...! ;)

[MarcoGG]

esempio:
- in a1:h1 del file archivio.xls la colonna b3:b5 del file 1.xls nella cartella
C:\Users\...\mesi\gennaio\1.xls
- in a2:h2 del file archivio.xls la colonna b3:b5 del file 2.xls nella cartella
C:\Users\...\mesi\gennaio\1.xls
etc etc

Spero di essere stata chiara, se mi scrivete il codice vba vi ringrazierò per l'eternità...! ;)

Abbastanza chiaro, a parte il fatto che [B3:B5] sono 3 celle, mentre il Range destinazione su archivio occupa per ogni record 8 celle : [A1:H1] ?! :stordita:

[luana76]

da b3 a b10 ! scusa ho sbagliato....dai perfavore aiutami...non ne ho un idea di come si realizza....dai...

[MarcoGG]

da b3 a b10 ! scusa ho sbagliato....dai perfavore aiutami...non ne ho un idea di come si realizza....dai...

E' abbastanza semplice, anche se non immediata come soluzione. Buttata giù così in pochi minuti, la risolverei con un paio di Function e un pulsante da mettere su "Foglio1" di archivio.xls :

> Le Function :

Private Function LeggiValore(percorsoWBook As String, nomeWBook As String, nomeWSheet As String, indirizzo As String) As Variant

Dim strMacro As String
strMacro = "'" & percorsoWBook & "[" & nomeWBook & "]" & nomeWSheet & "'!" & Range(indirizzo).Address(True, True, xlR1C1)
LeggiValore = ExecuteExcel4Macro(strMacro)

End Function

Private Function UltimaRigaUtile(nomeFoglio As String) As Long

Dim UR As Long
If WorksheetFunction.CountA(Worksheets(nomeFoglio).Cells) > 0 Then
UR = Worksheets(nomeFoglio).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
UltimaRigaUtile = UR
Else
UltimaRigaUtile = 0
End If

End Function

> Codice pulsante :

Dim cartellaRoot As String
cartellaRoot = ThisWorkbook.Path & "\"
Dim cartellaMese As String
Dim arrayMesi() As Variant
arrayMesi = Array("gennaio", "febbraio", ..., ..., "dicembre")
Dim nomeFileGiorno As String

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim numRiga As Long

For i = 0 To UBound(arrayMesi)
cartellaMese = arrayMesi(i)
For j = 1 To 31
numRiga = UltimaRigaUtile("Foglio1") + 1
nomeFileGiorno = j & ".xls"
If Dir(cartellaRoot & cartellaMese & "\" & nomeFileGiorno) <> "" Then
For k = 1 To 8
Cells(numRiga, k).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, "Foglio1", "B" & (k + 2))
Next k
End If
Next j
Next i
MsgBox "FATTO. ;)"

N.B.:
1. arrayMesi = Array("gennaio", "febbraio", ..., ..., "dicembre")
Ovviamente devi mettere tutti i mesi, da gen a dic.

2. numRiga = UltimaRigaUtile("Foglio1") + 1
Foglio1 è il nome del foglio di archivio.xls in cui vuoi inserire i dati, e su cui va messo il codice ( Functions + pulsante ).

3. Cells(numRiga, k).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, "Foglio1", "B" & (k + 2))
In questo caso Foglio1 invece è il nome foglio dei file da cui prelevi i dati.

E direi che il gioco è fatto. :cool: ;)

[luana76]

ti ringrazio di cuore per il tempo che mi dedichi, grazie infinite!
Approfitto della tua gentilezza perchè non ne ho un idea di come si fa..
ho implementato il codice che mi hai scritto nel file archivio.xls, ma ho dei problemi,il codice gira ma non si ferma mai, non capisco dove ho sbagliato,
il codice che ho scritto è questo:

---------------------------------------------------
Private Function LeggiValore(percorsoWBook As String, nomeWBook As String, nomeWSheet As String, indirizzo As String) As Variant

Dim strMacro As String
strMacro = "'" & percorsoWBook & "[" & nomeWBook & "]" & nomeWSheet & "'!" & Range(indirizzo).Address(True, True, xlR1C1)
LeggiValore = ExecuteExcel4Macro(strMacro)

End Function

Private Function UltimaRigaUtile(nomeFoglio As String) As Long

Dim UR As Long
If WorksheetFunction.CountA(Worksheets(nomeFoglio).Cells) > 0 Then
UR = Worksheets(nomeFoglio).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
UltimaRigaUtile = UR
Else
UltimaRigaUtile = 0
End If

End Function

Sub Macro8()
Dim cartellaRoot As String
cartellaRoot = ThisWorkbook.Path & "\"
Dim cartellaMese As String
Dim arrayMesi() As Variant
arrayMesi = Array("gennaio", "febbraio", "marzo", "aprile", "maggio", "giugno", "luglio", "agosto", "settembre", "ottobre", "novembre", "dicembre")
Dim nomeFileGiorno As String

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim numRiga As Long

For i = 0 To UBound(arrayMesi)
cartellaMese = arrayMesi(i)
For j = 1 To 31
numRiga = UltimaRigaUtile("Foglio1") + 1
nomeFileGiorno = j & ".xls"
If Dir(cartellaRoot & cartellaMese & "\" & nomeFileGiorno) <> "" Then
For k = 1 To 8
Cells(numRiga, k).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, "01", "B" & (k + 2))
Next k
End If
Next j
Next i
MsgBox "FATTO. ;)"
End Sub
----------------
Come ti avevo scritto ho creato le cartelle in questo ordine:

C:\Users\...\Desktop\mesi\
in questa cartella sul desktop ci sono il file archivio.xls (qui ho messo tutte le function e macro che mi hai scritto) e le cartelle con i nomi dei mesi gennaio,febbraio etc..
nelle cartelle
C:\Users\...\Desktop\mesi\gennaio\1.xls
C:\Users\...\Desktop\mesi\gennaio\2.xls
...
C:\Users\...\Desktop\mesi\febbraio\1.xls

Come mi chiedevi ho modificato nel codice il ''Foglio1'' nel file archivio, mentre la pagina dei file giornalieri è indicata come ''01''. Poi ho creato un pulsante sulla pagina ''Foglio1'' di archivio.xls e gli ho associato una macro col ''codice pulsante'' che mi hai scritto. Purtroppo vedo che gira ma non si ferma mai.

Scusami se ti faccio perdere tempo.. cmq mi approfitto della tua disponibilità...grazie ancora

[MarcoGG]

Non penso che il codice possa dare adito a cicli infiniti, in quanto ho usato solo cicli For... Probabilmente non gli dai il tempo di finire. Quanto hai aspettato prima di concludere che "non finisce mai" ?
Tieni presente che se hai un anno intero esegui circa 3000 operazioni di lettura da WorkBook chiuso e altrettante di scrittura su archivio. Intanto sostituisci il codice del pulsante con questo - inoltre proviamo con un mese solo :

Dim cartellaRoot As String
cartellaRoot = ThisWorkbook.Path & "\"
Dim cartellaMese As String
Dim arrayMesi() As Variant
arrayMesi = Array("gennaio")
Dim nomeFileGiorno As String

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim numRiga As Long

Application.ScreenUpdating = False
For i = 0 To UBound(arrayMesi)
cartellaMese = arrayMesi(i)
For j = 1 To 31
numRiga = UltimaRigaUtile("Foglio1") + 1
nomeFileGiorno = j & ".xls"
If Dir(cartellaRoot & cartellaMese & "\" & nomeFileGiorno) <> "" Then
For k = 1 To 8
Cells(numRiga, k).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, "Foglio1", "B" & (k + 2))
Next k
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "FATTO. ;)"

Dovrebbe andare più veloce. Ce la fa a finire ?

[luana76]

adesso va tutto!!! sei un grande!
ho provato come mi avevi detto e il codice funziona, ho provato con 3 mesi e va bene, il codice è perfetto.
ti chiedo un ultimo aiuto per effettuare una modifica che mi sono accorto sia essenziale:

1) ho modificato la function:
Private Function UltimaRigaUtile(nomeFoglio As String) As Long

Dim UR As Long
If WorksheetFunction.CountA(Worksheets(nomeFoglio).Cells) > 0 Then
UR = Worksheets(nomeFoglio).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
UltimaRigaUtile = UR
Else
UltimaRigaUtile = 1
End If

per farla partire dalla seconda riga, in modo che riesco a scrivere un intestazione. Mi chiedevo se era possibile ogni volta che faccio partire la macro,farla partire dalla riga 2 ogni volta che la attivo(partendo dalle celle A2-H2 del Foglio1 di archivio.xls).Attualmente ogni voltà che clicco il pulsante mi compila i campi vuoti sotto quelli che ha già compilato dalle precedenti attivazioni della macro.
In pratica mi servirebbe solo un aggiornamento dei dati già scritti.

2)poi ho verificato che i file giornalieri nelle varie cartelle mesi (1.xls,2.xls..)hanno solo una pagina da cui acquisiscono che è numerata con due cifre così: 01 per il 1.xls, 02 per 2.xls, ..., 31 per 31.xls, e non con "Foglio1" come ti avevo detto, è modificabile in qualche modo ?

3) l'ultima cosa, è possibile aggiungere la casella A2 di ogni file giornaliero nella corrispondente riga che viene copiata nel file archivio, tipo in posizione corrispondente alla colonna I ( in pratica, prendendo come esempio il file 1.xls di gennaio, viene copiata la colonna B3-B10 nella riga di archivio A2-H2 e la cella A2 di 1.xls in I2 di archivio.xls, e così via andare.

Ti ringrazio ancora e scusami ancora se approfitto della tua bravura..
Grazie ancora!!!

[MarcoGG]

Semplice. Puoi implementare le modifiche 1) 2) e 3) sostituendo il precedente codice pulsante con questo :

Columns("A:H").ClearContents

Dim cartellaRoot As String
cartellaRoot = ThisWorkbook.Path & "\"
Dim cartellaMese As String
Dim arrayMesi() As Variant
arrayMesi = Array("gennaio")
Dim nomeFileGiorno As String
Dim nomeFoglioGiorno As String

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim numRiga As Long

Application.ScreenUpdating = False
For i = 0 To UBound(arrayMesi)
cartellaMese = arrayMesi(i)
For j = 1 To 31
numRiga = UltimaRigaUtile("Foglio1") + 1
nomeFileGiorno = j & ".xls"
If Len(CStr(j)) = 1 Then
nomeFoglioGiorno = "0" & j
Else
nomeFoglioGiorno = j
End If
If Dir(cartellaRoot & cartellaMese & "\" & nomeFileGiorno) <> "" Then
For k = 1 To 8
Cells(numRiga, k).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, nomeFoglioGiorno, "B" & (k + 2))
Next k
Range("I" & numRiga).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, nomeFoglioGiorno, "A2")
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "FATTO. ;)"

;)

[luana76]

evito di dirti che sei un fenomeno.
adesso va tutto, solo che ho un problema: l'ho provato e compilava perfettamente tutto, ma poi ho inserito nel file archivio.xls delle pagine riepilogative per mesi con dei grafici che leggevano i dati dal "foglio1" e il codice non andava più, o meglio partiva a scrivere i dati dalle caselle a367:i367, praticamente dalle celle non considerate dai grafici delle altre pagine,e se eventualmente lo riaggiorno cliccando sul pulsante mi scrive il tutto dopo la sequenza di dati già scritti, in breve non rinizia dalla riga 2 del Foglio1.

Cosa può essere? un conflitto tra i grafici e la macro?
....se puoi aiutarmi come al solito data la mia ignoranza...

ti riposto il codice per sicurezza(ho solo aggiunto tutte le variabili mesi)



-----------------
Private Function LeggiValore(percorsoWBook As String, nomeWBook As String, nomeWSheet As String, indirizzo As String) As Variant

Dim strMacro As String
strMacro = "'" & percorsoWBook & "[" & nomeWBook & "]" & nomeWSheet & "'!" & Range(indirizzo).Address(True, True, xlR1C1)
LeggiValore = ExecuteExcel4Macro(strMacro)

End Function

-----------------
Private Function UltimaRigaUtile(nomeFoglio As String) As Long

Dim UR As Long
If WorksheetFunction.CountA(Worksheets(nomeFoglio).Cells) > 0 Then
UR = Worksheets(nomeFoglio).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
UltimaRigaUtile = UR
Else
UltimaRigaUtile = 1
End If

End Function

Sub Macro1()

Columns("A:H").ClearContents

Dim cartellaRoot As String
cartellaRoot = ThisWorkbook.Path & "\"
Dim cartellaMese As String
Dim arrayMesi() As Variant
arrayMesi = Array("gennaio", "febbraio", "marzo", "aprile", "maggio", "giugno", "luglio", "agosto", "settembre", "ottobre", "novembre", "dicembre")
Dim nomeFileGiorno As String
Dim nomeFoglioGiorno As String

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim numRiga As Long

Application.ScreenUpdating = False
For i = 0 To UBound(arrayMesi)
cartellaMese = arrayMesi(i)
For j = 1 To 31
numRiga = UltimaRigaUtile("Foglio1") + 1
nomeFileGiorno = j & ".xls"
If Len(CStr(j)) = 1 Then
nomeFoglioGiorno = "0" & j
Else
nomeFoglioGiorno = j
End If
If Dir(cartellaRoot & cartellaMese & "\" & nomeFileGiorno) <> "" Then
For k = 1 To 8
Cells(numRiga, k).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, nomeFoglioGiorno, "B" & (k + 2))
Next k
Range("I" & numRiga).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, nomeFoglioGiorno, "A2")
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "FATTO. ;)"

End Sub

[MarcoGG]

evito di dirti che sei un fenomeno.
adesso va tutto, solo che ho un problema: l'ho provato e compilava perfettamente tutto, ma poi ho inserito nel file archivio.xls delle pagine riepilogative per mesi con dei grafici che leggevano i dati dal "foglio1" e il codice non andava più
...


Il fatto è che io ti avevo detto "codice pulsante", dando per scontato che andasse associato direttamente al Click di un pulsante posto sullo stesso Sheet in cui i dati vanno registrati.
Non c'è alcun conflitto con i grafici, che si limitano a leggere da Foglio1 e perciò non interferiscono con la routine.
In ogni caso credo si possa risolvere eliminando ogni ambiguità che si è probabilmente creata nel momento in cui hai aggiunto fogli nuovi. Perciò basta aggiungere riferimenti espliciti alle istruzioni che ne sono sprovviste. Inoltre bisogna notare che adesso le colonne di Foglio1 vanno da A ad I, quindi :

Sheets("Foglio1").Columns("A:I").ClearContents

Dim cartellaRoot As String
cartellaRoot = ThisWorkbook.Path & "\"
Dim cartellaMese As String
Dim arrayMesi() As Variant
arrayMesi = Array("gennaio", "febbraio", "marzo", "aprile", "maggio", "giugno", "luglio", "agosto", "settembre", "ottobre", "novembre", "dicembre")
Dim nomeFileGiorno As String
Dim nomeFoglioGiorno As String

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim numRiga As Long

Application.ScreenUpdating = False
For i = 0 To UBound(arrayMesi)
cartellaMese = arrayMesi(i)
For j = 1 To 31
numRiga = UltimaRigaUtile("Foglio1") + 1
nomeFileGiorno = j & ".xls"
If Len(CStr(j)) = 1 Then
nomeFoglioGiorno = "0" & j
Else
nomeFoglioGiorno = j
End If
If Dir(cartellaRoot & cartellaMese & "\" & nomeFileGiorno) <> "" Then
For k = 1 To 8
Sheets("Foglio1").Cells(numRiga, k).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, nomeFoglioGiorno, "B" & (k + 2))
Next k
Sheets("Foglio1").Range("I" & numRiga).FormulaR1C1 = LeggiValore(cartellaRoot & cartellaMese & "\", nomeFileGiorno, nomeFoglioGiorno, "A2")
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "FATTO. ;)"
;)