Ciao Flavia,
L'ideale sarebbe mantenere i nomi originali dei vari fogli ma se questo non dovesse essere possibile va benissimo anche come hai suggerito tu. Posso sempre rinominarli dopo se necessario.
OK, ma nota che questo metodo richieda che i nomi di tutti i fogli di tutti i file di interesse siano unici in quanto non è possibile avere due fogli con lo stesso nome nello stesso file.
Detto ciò, prova a sostituire il codice precedente con la seguente versione:
'===========>>
Option Explicit
Private Const sPercorso As String = _
"**C:\Users\Flavia\Documenti\Pippo**" '<<=== Modifica
Private Const sFileType As String = "***.**xlsx" '<<=== Modifica
'----------->>
Public Sub CreaFoglioPerOgniFoglioDiOgniFileInCartella()
Dim FSO As Object
Dim oFile As Object
Dim oFiles As Object
Dim oFolder As Object
Dim srcWb As Workbook, destWB As Workbook
Dim SH As Worksheet, srcSH As Worksheet, destSH As Worksheet
Dim srcRng As Range, destRng As Range
Dim iCtr As Long, jCtr As Long, iSheets As Long
Dim LRow As Long, LCol As Long
Dim sName As String
Dim sMsg As String, sTitle As String
Dim iButtons As Long
Dim CalcMode As Long
On Error GoTo XIT
Set destWB = ThisWorkbook
iSheets = destWB.Sheets.Count
On Error Resume Next
With Application
.EnableEvents = False
.ScreenUpdating = False
CalcMode = .Calculation
.Calculation = xlCalculationManual
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(sPercorso)
If oFolder Is Nothing Then
Err.Raise 76
GoTo XIT
End If
Set oFiles = oFolder.Files
If oFiles Is Nothing Then
Err.Raise 100
GoTo XIT
End If
For Each oFile In oFiles
With oFile
If .Name Like sFileType Then
iCtr = iCtr + 1
Set srcWb = Workbooks.Open(oFile)
For Each SH In srcWb.Worksheets
jCtr = jCtr + 1
Set srcSH = SH
With srcSH
LRow = LastRow(srcSH, .Columns("A:A"))
LCol = LastCol(srcSH)
Set srcRng = .Range("A1").Resize(LRow, LCol)
End With
sName = SH.Name
With destWB
If Not SheetExists(sName) Then
Set destSH = .Sheets.Add(after:=.Sheets(.Sheets.Count))
destSH.Name = sName
Else
Set destSH = .Sheets(sName)
destSH.UsedRange.ClearContents
End If
End With
Set destRng = destSH.Range("A1")
srcRng.Copy
With destRng
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With
Next SH
srcWb.Close savechanges:=False
End If
End With
Next oFile
Call SortWorksheets(aWB:=ThisWorkbook, _
iPrimoFoglioDaOrdinare:=iSheets + 1, _
SortDescending:=False)
If Not CBool(iCtr) Then
Call MsgBox( _
Prompt:="Nessun file del tipo designato " & sFileType _
& " è stato trovato ", _
Buttons:=vbInformation, _
Title:="REPORT")
Exit Sub
End If
XIT:
With Application
.ScreenUpdating = True
.Calculation = CalcMode
.EnableEvents = True
End With
Select Case Err.Number
Case Is = 0
sMsg = "Finito!" _
& vbNewLine & vbNewLine _
& iCtr & " file comprendendo " _
& jCtr & " fogli di lavoro sono stati gestiti"
sTitle = "REPORT"
iButtons = vbInformation
Case Is = 76
sMsg = "Il percorso " & sPercorso & " non è valido!"
iButtons = vbCritical
sTitle = "CONTROLLA PERCORSO!"
Case 100
sMsg = "Nessun file del tipo " _
& sFileType _
& " è stato trovato!"
iButtons = vbCritical
sTitle = "CONTROLLA CARTELLA!"
Case Else
sMsg = "Errore " & Err.Number _
& vbNewLine & Err.Description
iButtons = vbCritical
sTitle = "ERRORE!"
End Select
Call MsgBox( _
Prompt:=sMsg, _
Buttons:=iButtons, _
Title:=sTitle)
End Sub
'----------->>
Public Sub CreaRiepilogoPerOgniFileInCartella()
Dim FSO As Object
Dim oFile As Object
Dim oFiles As Object
Dim oFolder As Object
Dim srcWb As Workbook, destWB As Workbook
Dim srcSH As Worksheet, destSH As Worksheet
Dim srcRng As Range, destRng As Range
Dim arrIn() As Variant, arrHeaders() As Variant
Dim iCtr As Long, jCtr As Long, kCtr As Long
Dim i As Long, j As Long
Dim LRow As Long, iCol As Long
Dim sName As String
Dim sMsg As String, sTitle As String
Dim iButtons As Long
Dim CalcMode As Long
Const sSummary As String = "Riepilogo" '<<=== Modifica
Const sUltimaColonna As String = "G" '<<=== Modifica
On Error GoTo XIT
Set destWB = ThisWorkbook
With destWB
On Error Resume Next
With Application
.EnableEvents = False
.ScreenUpdating = False
CalcMode = .Calculation
.Calculation = xlCalculationManual
End With
If Not SheetExists(sSummary) Then
Set destSH = destWB.Sheets.Add(after:=.Sheets(.Sheets.Count))
destSH.Name = sSummary
Else
Set destSH = .Sheets(sSummary)
destSH.UsedRange.Offset(1).ClearContents
End If
End With
iCol = destSH.Columns(sUltimaColonna).Column
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(sPercorso)
If oFolder Is Nothing Then
Err.Raise 76
GoTo XIT
End If
Set oFiles = oFolder.Files
If oFiles Is Nothing Then
Err.Raise 100
GoTo XIT
End If
For Each oFile In oFiles
With oFile
If .Name Like sFileType Then
kCtr = kCtr + 1
Set srcWb = Workbooks.Open(oFile)
Set srcSH = srcWb.Sheets(1)
With srcSH
LRow = LastRow(srcSH, .Columns("A:A"))
Set srcRng = .Range("A2").Resize(LRow - 1, iCol)
jCtr = iCtr
iCtr = iCtr + LRow - 1
If Not IsArrayAllocated(arrHeaders) Then
arrHeaders = srcRng.Rows(0).Value
ReDim Preserve arrHeaders(1 To 1, 1 To iCol + 1)
arrHeaders(1, iCol + 1) = "File Originario"
End If
End With
ReDim Preserve arrIn(1 To iCol + 1, 1 To iCtr)
For i = 1 To LRow - 1
For j = 1 To iCol
arrIn(j, jCtr + i) = srcRng.Cells(i, j).Value
Next j
arrIn(j, jCtr + i) = oFile.Name
Next i
srcWb.Close savechanges:=False
End If
End With
Next oFile
If Not CBool(iCtr) Then
Call MsgBox( _
Prompt:="Nessun file del tipo designato " & sFileType _
& " è stato trovato ", _
Buttons:=vbInformation, _
Title:="REPORT")
Exit Sub
End If
With destSH
Set destRng = destSH.Range("A2").Resize(iCtr, j)
destRng.Value = Application.Transpose(arrIn)
With destRng.Rows(0)
.Value = arrHeaders
.Font.Bold = True
End With
.UsedRange.EntireColumn.AutoFit
End With
XIT:
With Application
.ScreenUpdating = True
.Calculation = CalcMode
.EnableEvents = True
End With
Select Case Err.Number
Case Is = 0
sMsg = "Finito!" _
& vbNewLine & vbNewLine _
& kCtr & " file sono stati gestiti"
sTitle = "REPORT"
iButtons = vbInformation
Case Is = 76
sMsg = "Il percorso " & sPercorso & " non è valido!"
iButtons = vbCritical
sTitle = "CONTROLLA PERCORSO!"
Case 100
sMsg = "Nessun file del tipo " _
& sFileType _
& " è stato trovato!"
iButtons = vbCritical
sTitle = "CONTROLLA CARTELLA!"
Case Else
sMsg = "Errore " & Err.Number _
& vbNewLine & Err.Description
iButtons = vbCritical
sTitle = "ERRORE!"
End Select
Call MsgBox( _
Prompt:=sMsg, _
Buttons:=iButtons, _
Title:=sTitle)
End Sub
'--------->>
Public Sub SortWorksheets(Optional aWB, _
Optional iPrimoFoglioDaOrdinare As Long = 1, _
Optional SortDescending As Boolean = False)
Dim i As Long, j As Long
Dim iSheets As Long
If IsMissing(aWB) Then
Set aWB = ActiveWorkbook
End If
With aWB
iSheets = .Worksheets.Count
For j = iPrimoFoglioDaOrdinare To iSheets
For i = j To iSheets
If SortDescending = True Then
If UCase(.Worksheets(i).Name) > UCase(.Worksheets(j).Name) Then
.Worksheets(i).Move Before:=.Worksheets(j)
End If
Else
If UCase(.Worksheets(i).Name) < UCase(.Worksheets(j).Name) Then
.Worksheets(i).Move Before:=.Worksheets(j)
End If
End If
Next i
Next j
End With
End Sub
'----------->>
Public Function LastRow(SH As Worksheet, _
Optional Rng As Range, _
Optional minRow As Long = 1, _
Optional strPassword As String)
Dim bProtected As Boolean
With SH
If Rng Is Nothing Then
Set Rng = .Cells
End If
bProtected = .ProtectContents = True
If bProtected Then
.Unprotect Password:=strPassword
End If
End With
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
If bProtected Then
SH.Protect Password:=strPassword, _
UserInterfaceOnly:=True
End If
End Function
'--------->>
Public Function LastCol(SH As Worksheet, _
Optional Rng As Range, _
Optional sPassword As String)
Dim bProtected As Boolean
With SH
If Rng Is Nothing Then
Set Rng = .Cells
End If
bProtected = .ProtectContents = True
If bProtected Then
.Unprotect Password:=sPassword
End If
End With
On Error Resume Next
LastCol = Rng.Find(What:="*", _
after:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
If bProtected Then
SH.Protect Password:=sPassword, _
UserInterfaceOnly:=True
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))
On Error GoTo 0
End Function
'--------->>
Public Function IsArrayAllocated(Arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(Arr) And _
Not IsError(LBound(Arr, 1)) And _
LBound(Arr, 1) <= UBound(Arr, 1)
End Function
'<<=========
Nota che, dato il numero di fogli da importare, per facilitarne la ricerca, ho aggiunto una procedura per ordinarli, in modo crescente, dopo i fogli esistenti.
===
Regards,
Norman
![](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)
