Moderatori: Anthony47, Flash30005
Non e' possibile che metti nella directory solo i file da importare e poi si importano Tutti i file presenti?i nomi dei file che devono essere importati sono diversi(ideale sarebbe poterli selezionare al momento della partenza della macro).
Sub RIEP()
Dim myDir As String, myCFile As String, myLast As Long, myDest As String
'
myDest = "Foglio1" '<<< Il Foglio in cui si creera' il riepilogo
myDir = "D:\PIPPO\Archivio\" '<<< La dir dei file da consolidare (con \ finale)
'
Application.EnableEvents = False
myCFile = Dir(myDir & "*.xls*")
Do
If myCFile = "" Then Exit Do
On Error Resume Next
myLast = getLast
Workbooks.Open (myDir & myCFile)
Sheets(1).Select
myused = getLast
If myLast = 0 Then
ActiveSheet.Range("A1:J" & myused).Copy ThisWorkbook.Sheets(myDest).Cells(myLast + 1, 1)
Else
ActiveSheet.Range("A2:J" & myused).Copy ThisWorkbook.Sheets(myDest).Cells(myLast + 1, 1)
End If
ActiveWorkbook.Close False
myCFile = Dir
Loop
Application.EnableEvents = True
MsgBox ("Completato...")
End Sub
Function getLast() As Long
Dim LastR As Long
On Error Resume Next
LastR = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
On Error GoTo 0
getLast = LastR
End Function
myDest = "Foglio1" '<<< Il Foglio in cui si creera' il riepilogo
Workbooks.Open (myDir & myCFile)
ActiveWorkbook.Close False
If myCFile = "" Then Exit Do
'....
Application.EnableEvents = False
Debug.Print vbCrLf & vbCrLf & ">>>>>>>>>> " '<<< Aggiungere per prova
myCFile = Dir(myDir & "*.xls*")
Do
If myCFile = "" Then Exit Do
'On Error Resume Next
myLast = getLast
Debug.Print myLast, myCFile '<<< Aggiungere per prova
Workbooks.Open (myDir & myCFile)
' etc etc
If myused > 0 Then 'IF aggiunto
If myLast = 0 Then
ActiveSheet.Range("A1:J" & myused).Copy ThisWorkbook.Sheets(myDest).Cells(myLast + 1, 1)
Else
ActiveSheet.Range("A2:J" & myused).Copy ThisWorkbook.Sheets(myDest).Cells(myLast + 1, 1)
End If
End If 'End dell' IF aggiunto
Sub RIEP2()
Dim myDir As String, myCFile As String, myLast As Long, myDest As String
Dim newWB As Workbook
'
'Crea il Riepilogo su un NUOVO WORKBOOK
'
myDest = "Foglio1" '<<< Il Foglio in cui si creera' il riepilogo
myDir = "D:\PIPPO\Archivio\" '<<< La dir dei file da consolidare (con \ finale)
'
Application.EnableEvents = False
Debug.Print vbCrLf & vbCrLf & ">>>>>>>>>> " '<<< Aggiungere per prova
Set newWB = Workbooks.Add '<<< Crea un nuovo Workbook
myCFile = Dir(myDir & "*.xls*")
Do
If myCFile = "" Then Exit Do
'On Error Resume Next
myLast = getLast
Debug.Print myLast, myCFile '<<< Aggiungere per prova
Workbooks.Open (myDir & myCFile)
Sheets(1).Select
myused = getLast
If myused > 0 Then 'IF aggiunto
If myLast = 0 Then
ActiveSheet.Range("A1:J" & myused).Copy newWB.Sheets(myDest).Cells(myLast + 1, 1)
Else
ActiveSheet.Range("A2:J" & myused).Copy newWB.Sheets(myDest).Cells(myLast + 1, 1)
End If
End If 'End dell' IF aggiunto
ActiveWorkbook.Close False
myCFile = Dir
Loop
Application.EnableEvents = True
MsgBox ("Riepilogo completato su nuovo File...")
End Sub
Torna a Applicazioni Office Windows
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
Inserire add.in nella barra di avvio veloce in excel 2003 Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 4 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
Stabilire righe e colonne da mostrare a schermo Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 10 |
Visitano il forum: Nessuno e 9 ospiti