copiare dati da 3 file excel differenti

Buongiorno a tutti, avrei necessità di implementare un codice lasciato in eredità da un collega, ma io so poco o nulla di VBA. qualcuno può aiutarmi?

in pratica devo copiare in un unico file i dati presenti in tre file differenti, salvati in 3 diverse directory di rete aziendale.

i file sono cosi organizzati:

due file (file 1 e file 2) hanno all'interno 31 fogli (uno per giorno del mese)

un file (file 3) ha all'interno 12 fogli (uno per mese)

io devo copiare i dati all'interno di tutti i fogli dei tre file in un unico file.

Vi posto il codice che ho già.

se qualcuno riesce a darmi una mano ne sarei grato.

grazie

'========>>
Option Explicit
'-------->>
Public Sub Tester()
Dim srcWB1 As Workbook, srcWB2 As Workbook, srcWB3 As Workbook, destWB As Workbook
Dim srcSH1 As Worksheet, srcSH2 As Worksheet, destSH As Worksheet
Dim srcRng1 As Range, srcRng2 As Range, destRng As Range, destRng2 As Range, tempRng As Range
Dim arrSorgente As Variant, arrDati() As Variant
Dim Res As Variant
Dim sPath As String, sPath2 As String, sStr As String, sstr2 As String
Dim iRow As Long, jRow As Long, kRow As Long, mRow As Long
Dim i As Long, j As Long, m As Long, iCtr As Long
Const sPercorso As String = "S:\percorso file 1"
Const sPercorso2 As String = "S:\percorso file 2\" '<<=== Modifica
Const sFile1 As String = "file 1.xls" '<<=== Modifica
Const sFile2 As String = "file 2.xlsx" '<<=== Modifica
Const sFoglio_Sorgente1 As String = "11" '<<=== Modifica
Const sFoglio_Sorgente2 As String = "Gennaio " '<<=== Modifica
Const sFoglio_Destinazione As String = "Riepilogo" '<<=== Modifica
Const iPrimaRiga1 As Long = 11 '<<=== Modifica
Const iPrimaRiga2 As Long = 7 '<<=== Modifica

sStr = Application.PathSeparator
If Right(sPercorso, 1) = sStr Then
sPath = sPercorso
Else
sPath = sPercorso & sStr
End If

sstr2 = Application.PathSeparator
If Right(sPercorso2, 1) = sstr2 Then
sPath2 = sPercorso2
Else
sPath2 = sPercorso2 & sstr2
End If

Set destWB = ThisWorkbook
With destWB
If SheetExists(sFoglio_Destinazione, destWB) Then
Set destSH = .Sheets(sFoglio_Destinazione)
With destSH
kRow = LastRow(srcSH1, .Columns("A:B"))
Set destRng = .Range("A" & kRow + 1)
End With
Else
Set destSH = .Sheets.Add(Before:=.Sheets(1))
With destSH
.Name = sFoglio_Destinazione
Set destRng = .Range("D2")
End With
End If
End With
Set srcWB1 = Workbooks.Open(sPath & sFile1)
Set srcWB2 = Workbooks.Open(sPath2 & sFile2)
Set srcSH1 = srcWB1.Sheets(sFoglio_Sorgente1)
Set srcSH2 = srcWB2.Sheets(sFoglio_Sorgente2)
With srcSH1
iRow = LastRow(srcSH1, .Columns("g:p"))
Set srcRng1 = .Range("g" & iPrimaRiga1).Resize(iRow - iPrimaRiga1 + 1, 16)
End With
arrSorgente = srcRng1.Value
With srcSH2
jRow = LastRow(srcSH1, .Columns("D:D"))
Set tempRng = .Range("D" & iPrimaRiga2).Resize(jRow - iPrimaRiga2 + 1)
.Select
End With
On Error Resume Next
Application.DisplayAlerts = False
Set srcRng2 = Application.InputBox(Prompt:= _
"Seleziona l'intervallo della colonna da copiare sul foglio " _
& sFoglio_Sorgente2 & " del " _
& sFile2, _
Title:="Seleziona Intervallo da copiare", _
Default:=tempRng.Address, _
Type:=8)
Application.DisplayAlerts = True
On Error GoTo 0
If srcRng2 Is Nothing Then
Call MsgBox(Prompt:="Non hai selezionato un intervallo da copiare!", _
Buttons:=vbCritical, _
Title:="PROBLEMA!")
Exit Sub
End If
For i = LBound(arrSorgente, 2) To UBound(arrSorgente, 2) Step 3
For j = LBound(arrSorgente) To UBound(arrSorgente) Step 5
iCtr = iCtr + 1
ReDim Preserve arrDati(1 To iCtr)
arrDati(iCtr) = arrSorgente(j, i)
Next j
Next i
destRng.Resize(iCtr).Value = Application.Transpose(arrDati)
destRng.Offset(0, 1).Resize(srcRng2.Rows.Count).Value = srcRng2.Value
Call MsgBox(Prompt:="Fatto", _
Buttons:=vbInformation, _
Title:="REPORT")
End Sub
'--------->>
Public Function LastRow(sh As Worksheet, _
Optional rng As Range, _
Optional minRow As Long = 1)
If rng Is Nothing Then
Set rng = sh.Cells
End If
On Error Resume Next
LastRow = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
If LastRow < minRow Then
LastRow = minRow
End If
End Function
'--------->>
Public Function SheetExists(sSheetName As String, _
Optional ByVal WB As Workbook) As Boolean
On Error Resume Next
If WB Is Nothing Then
Set WB = ThisWorkbook
End If
SheetExists = CBool(Len(WB.Sheets(sSheetName).Name))
End Function
'<<========