Ciao Mauro ti voglio ringraziaree davvero tanto. Funziona tutto alla grande..
Se non ti disturbo troppo vorrei chiederti un'altra domanda riguardo a questa cosa e poi prommetto che non ti disturbo più.
Allora se volessi che nel file finale venga inserita un'altra colonna (in modo automatico) che davanti ai dati importati dalla cartella "notespese" mi prenda la cella "D4 (con
il rispettivo nome che c'è dentro la cella)" di tutti i file che si trovano all'interno della cartella e che si inserisca in automatico davanti ai dati.. come in questo esempio:
Link
E' l'ultima cosa che ti chiedo.. te lo prommetto
Ma figurati. E' un tuo diritto chiedere.
Io però aggiungerei a mano(lo fai tu) la colonna A. Questo il codice modificato per fare quanto chiedi:
Public Sub m()
On Error GoTo RigaErrore
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim wrk As Workbook
Dim sh As Worksheet
Dim shStorico As Worksheet
Dim wkStorico As Workbook
Dim lUltRiga As Long
Dim lRiga As Long
Dim sPath As String
Dim s As String
With Application
.ScreenUpdating = False
.Calculation = xlManual
.StatusBar = "Sto eseguendo: Sub m()"
End With
sPath = "C:\Prova\miaCartella"
Set wkStorico = ThisWorkbook
Set shStorico = wkStorico.Worksheets("Sheet1")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(sPath)
For Each objFile In objFolder.Files
If Right(objFile.Name, 3) = "xls" _
Or Right(objFile.Name, 4) = "xlsx" _
Or Right(objFile.Name, 4) = "xlsm" Then
Set wrk = Workbooks.Open(sPath & objFile.Name)
With wrk
Set sh = .Worksheets("Sheet1")
End With
lUltRiga = shStorico.Range("D" _
& Rows.Count).End(xlUp).Row + 1
If lUltRiga < 5 Then lUltRiga = 5
With sh
lRiga = .Range("D" & .Rows.Count).End(xlUp).Row
.Range("A15:R" & lRiga).Copy
shStorico.Range("A" & lUltRiga).PasteSpecial xlPasteValues
End With
With shStorico
lRiga = .Range("D" & .Rows.Count).End(xlUp).Row
s = Mid(objFile.Name, 9, Len(objFile.Name))
.Range("A" & lUltRiga & ":A" & lRiga).Value = Left(s, InStr(s, ".") - 1)
End With
wrk.Close
End If
Next
RigaChiusura:
Set sh = Nothing
Set wrk = Nothing
Set shStorico = Nothing
Set wkStorico = Nothing
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.StatusBar = ""
End With
Exit Sub
RigaErrore:
MsgBox Err.Number & vbNewLine & Err.Description
Resume RigaChiusura
End Sub
Fai sempre prove accurate prima di metterlo in produzione. Grazie per l'attenzione.
--
La soluzione, il codice ed i files sono forniti *così come sono* e l’autore declina ogni responsabilità per eventuali problemi causati dalla soluzione proposta se usata impropriamente. Create e utilizzate una copia del file per le vostre prove, *prima* di utilizzare
il codice o la soluzione in files importanti.
--
Mauro Gamberini - Microsoft© MVP(Excel)
http://www.maurogsc.eu
![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
